サブフォルダに格納されているファイルを、ファイル名ごとに条件分岐させたい

お世話になっております。
当方VBA初心者のため、ご教示ください。

張りつけするファイル(xlsx)と同フォルダ内に「Voltから始まるファイル(CSV)」と「Currから始まるファイル(CSV)」が大量にサブフォルダに格納されています。
Voltの時とCurrの時ではりつける場所を変えるマクロが知りたいです。
また、グラフの作成(範囲の修正)もしたいです。

①開くサブフォルダを指定する
(調べていて見つけたのが、ダイアログボックスでフォルダを指定するタイプでした。)

②Voltの時、C5～C135に入力されている数値をコピー、別ファイルのAK6に貼り付ける
ファイルごとに最終列の隣へどんどん貼り付けていく

③ファイルごとに数字を追加
フォルダが変わると数字を1～にする

※1フォルダにVolt5個、Curr5個程度(どちらもたまに6個)入っています。
2行目にフォルダの日付、3行目に1～、4行目に1回目～5回目(たまに6回目)と記載したい
3行目のフォルダ数は日付によって違います。

④貼り付ける前でも後でも良いのですが、1行ごとに空白行を挿入する
例）AK141：0.365
AK142：空白
AK143：0.412

⑤折れ線グラフの作成
貼り付けた6行目と141行目の1行を折れ線グラフにする(空白行は飛ばしてすべての行を128個作成)
グラフについては、すでにAJ列まで作成済みのものがありますので、可能であれば追加した列分の範囲の修正を行いたいです。

上記のことがしたいのですが、初心者なため、サンプルコードをいただけるとありがたいです。
また、マクロで再現が難しいということがあればご教示願います。

お手数をおかけしますが、よろしくお願いいたします。

No.1 回答者： amerikaumare 回答日時： 2024/07/22 10:50

あまりにも暑いので 自分で回答する気力がなかったので ChatGPTに丸投げしましたら、回答が来ましたので、下記に記します。

VBAを使用して指定の条件を満たすマクロを作成するには、以下の手順に従います。
１．サブフォルダを選択するためのダイアログボックス表示
２．VoltファイルとCurrファイルの処理
３．必要な数値のコピーと貼り付け
４．空白行の挿入
５．折れ線グラフの作成または範囲修正
以下にサンプルコードを示します。

Sub ProcessFiles()
Dim FolderPath As String
Dim VoltFiles As Collection
Dim CurrFiles As Collection
Dim FileName As String
Dim ws As Worksheet
Dim TargetCol As Long
Dim i As Long, j As Long
Dim DateFolder As String
Dim RunCounter As Integer

' ダイアログボックスでフォルダを指定
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "フォルダを選択"
If .Show = -1 Then
FolderPath = .SelectedItems(1) & "\"
Else
Exit Sub
End If
End With

' サブフォルダ内のVoltとCurrファイルを収集
Set VoltFiles = New Collection
Set CurrFiles = New Collection
FileName = Dir(FolderPath & "*.csv", vbNormal)

Do While FileName <> ""
If Left(FileName, 4) = "Volt" Then
VoltFiles.Add FolderPath & FileName
ElseIf Left(FileName, 4) = "Curr" Then
CurrFiles.Add FolderPath & FileName
End If
FileName = Dir
Loop

' 日付フォルダ名を取得
DateFolder = Format(Date, "yyyymmdd")

' Voltファイルの処理
Set ws = ThisWorkbook.Sheets("Sheet1") ' 貼り付ける対象シート
TargetCol = ws.Cells(3, Columns.Count).End(xlToLeft).Column + 1

RunCounter = 1
For Each FileName In VoltFiles
Call ProcessCSV(FileName, ws, "Volt", TargetCol, RunCounter, DateFolder)
RunCounter = RunCounter + 1
TargetCol = TargetCol + 2 ' 空白行を含む
Next FileName

' Currファイルの処理
TargetCol = ws.Cells(3, Columns.Count).End(xlToLeft).Column + 1
RunCounter = 1
For Each FileName In CurrFiles
Call ProcessCSV(FileName, ws, "Curr", TargetCol, RunCounter, DateFolder)
RunCounter = RunCounter + 1
TargetCol = TargetCol + 2 ' 空白行を含む
Next FileName

' グラフの更新（必要に応じて）
' ここでグラフの範囲を修正するコードを追加
End Sub

Sub ProcessCSV(FileName As String, ws As Worksheet, FileType As String, TargetCol As Long, RunCounter As Integer, DateFolder As String)
Dim Data As Variant
Dim i As Long

' CSVファイルを開く
Workbooks.Open FileName:=FileName
Data = ActiveSheet.Range("C5:C135").Value
ActiveWorkbook.Close False

' 日付とランカウントを記載
ws.Cells(2, TargetCol).Value = DateFolder
ws.Cells(3, TargetCol).Value = RunCounter

' データを貼り付け
For i = 1 To UBound(Data, 1)
ws.Cells(6 + (i - 1) * 2, TargetCol).Value = Data(i, 1)
Next i
End Sub


解説
１．フォルダの選択
・Application.FileDialog(msoFileDialogFolderPicker) を使用して、ユーザーにフォルダを選択させます。
２．VoltファイルとCurrファイルの収集
・Dir関数を使用して、指定フォルダ内のCSVファイルを収集し、ファイル名の先頭4文字が"Volt"または"Curr"であるファイルをそれぞれのコレクションに追加します。
３．CSVファイルの処理
・ProcessCSVサブプロシージャを呼び出して、各ファイルのデータを指定の範囲にコピーして貼り付けます。
４．空白行の挿入
・データを貼り付ける際に、1行おきにデータを挿入し、空白行を確保します。
５．グラフの範囲修正
・グラフの更新については、貼り付けたデータ範囲を基にして修正するコードを追加することができます。

このコードを実行することで、指定フォルダ内のCSVファイルからデータを抽出し、Excelシートに貼り付けることができます。また、必要に応じてグラフの範囲修正も行えます。

お役に立てれば幸いです。何か追加の質問があれば、お知らせください。

この回答へのお礼

さっそくのご回答ありがとうございます。
暑いのでお身体ご自愛くださいませ。

こちら、マクロ回してみたのですが
「For Eachに指定する変数はバリアント型またはオブジェクト型でなければなりません」
というエラーが出て進みませんでした。
このエラーの対処法はありますでしょうか？

お礼日時：2024/07/22 11:50