またまた続きでExcelVBA

VBA

とりあえず、自分的に納得できる感じで動作するようになりました。

動作はこんな感じです。

  1. ユーザーにCSVファイルの入っているフォルダを選んでもらう。
  2. 指定されたフォルダにCSVファイルがある場合一つのCSVファイル→一枚のシートとして開く。
  3. 集計用シートを先頭に追加。必要項目名、セル幅等を設定。
  4. 各シートの任意のセルの値を集計用シートに貼り付ける。
  5. CSVファイルのあったフォルダに名前（シート名から取得）をつけ保存。

以下ソース

Sub CSVを開き集計()

''XL97,XL2000で確認済み　by 渡辺ひかる　 -Last Update-2002/12/24-13:01
Dim myFS As FileSearch
Dim mySvWb As Workbook
Dim i As Long
Dim ChDir As Variant
Dim bName As String
Dim Path As String

'CSVファイルの入っているフォルダを選択させる
With Application.FileDialog(msoFileDialogFolderPicker)
　　If .Show = True Then
　　　　ChDir = .SelectedItems(1)
　　Else
　　　　Exit Sub
　　End If
End With


Set myFS = Application.FileSearch
With myFS
　　.LookIn = ChDir
　　.Filename = "*.csv"
　　If .Execute > 0 Then
　　　　'保存用ブックを追加
　　　　Workbooks.Add
　　　　Set mySvWb = Workbooks(2)
　　　　For i = 1 To .FoundFiles.Count
　　　　　　'見つかったファイルを一つずつ開く
　　　　　　'（オプションは適宜変更してください）
　　　　　　Workbooks.OpenText Filename:=.FoundFiles(i), _
　　　　　　StartRow:=1, _
　　　　　　DataType:=xlDelimited, _
　　　　　　TextQualifier:=xlDoubleQuote, _
　　　　　　ConsecutiveDelimiter:=False, _
　　　　　　Comma:=True
　　　　　　'保存用ブックに移動
　　　　　　Sheets(1).Move After:=mySvWb.Worksheets(mySvWb.Sheets.Count)
　　　　'元のファイルを削除(適宜）
　　　　'Kill .FoundFiles(I)
　　　　Next i
　　　　'初期設定のシートを削除
　　　　Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select
　　　　Application.DisplayAlerts = False
　　　　ActiveWindow.SelectedSheets.Delete
　　　　Application.DisplayAlerts = True
　　Else
　　　　'検索結果が０なら
　　　　MsgBox "検索条件を満たすファイルはありません。"
　　End If
End With



Worksheets.Add
With ActiveSheet
　　.Name = "集計"
　　.Range("B1").Value = "日射量"
　　.Range("C1").Value = "太陽電池　出力電力量"
　　.Range("D1").Value = "ﾊﾟﾜｺﾝ出力電力量"
End With

Columns("B:D").AutoFit
Columns("A:A").ColumnWidth = 15

For i = 2 To Application.Sheets.Count

　　ActiveSheet.Range("A" & i).Value = Application.Sheets(i).Range("A1").Value
　　ActiveSheet.Range("B" & i).Value = Application.Sheets(i).Range("B27").Value
　　ActiveSheet.Range("C" & i).Value = Application.Sheets(i).Range("D27").Value
　　ActiveSheet.Range("D" & i).Value = Application.Sheets(i).Range("E27").Value

Next
bName = Mid(Application.Sheets(2).Name, 4, 4) & "年" & Mid(Application.Sheets(2).Name, 8, 2) & "月分"
'保存する

mySvWb.SaveAs Filename:=ChDir & "\" & bName
End Sub


これで父も喜んでくれるはず。