読者です 読者をやめる 読者になる 読者になる

またまた続きでExcelVBA

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

動作はこんな感じです。

  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
    '検索結果が0なら
    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


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