Excel VBA コードを教えてください。

やりたいことは、フォルダーの中のファイルのB12の値を一括で
アクティブシートのA１から下に順番にコピペをしたいです。
（画像を添付しました）
宜しくお願い致します。

No.3 回答者： tatsumaru77 回答日時： 2023/12/04 10:14

以下のようにしてください。

詳細条件が不明なので、以下のような仕様で作成しています。
１．フォルダの中のファイルは、拡張子が.xlsmのファイルを対象にする。
２．対象となるファイルに複数のシートがある場合、最も左側のシートの
B12のセルを対象とする。
３．値の格納先は、マクロ実行時に表示されているシートとする。
（マクロのあるファイルのシートに格納します）

Public Sub B12集計()
Dim FldrPicker As FileDialog
Dim fldPath As String
Dim fname As String
Dim ws As Worksheet
Dim wrow As Long: wrow = 1
Dim wb As Workbook
Set ws = ActiveSheet
'フォルダ選択ダイアログを表示
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "フォルダを選択してください。"
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
fldPath = .SelectedItems(1) & "\"
End With
Set ws = ActiveSheet
fname = Dir(fldPath & "*.xlsx")
Do While (fname <> "")
Set wb = Workbooks.Open(fldPath & fname)
ws.Cells(wrow, 1).Value = wb.Worksheets(1).Range("B12").Value
wb.Close (False)
wrow = wrow + 1
fname = Dir()
Loop
MsgBox ("完了")
End Sub

No.2 回答者： virgo_o_99 回答日時： 2023/12/03 00:48

すみません。

生成AIの回答をそのままコピペしたものです。

あと、マクロ実行のEXCELファイルは「～.xlsx」ではなくて「～.xlsm」なので、コードの「Active.xlsx」の部分は「Active.xlsm」に読み替えます。

ただ、テスト実行してみたところ、各々のB12セルの値を、１ファイルから10行分を転記してしまっています。
変数の加算がしくじっているようです。
生成AIでご自分でも条件設定してみると自動でコードを作成してくれるので、試してみてください。

No.1 回答者： virgo_o_99 回答日時： 2023/12/02 22:30

Excel VBAを使用して、同じフォルダにある複数のExcelファイル（01.xls,02.xls,03.xls,04.xls,05.xls,06.xls,07.xls,08.xls,09.xls,10.xls）の各sheet1のB12セルの値をActive.xlsxのSheet1のセルのA1～A10に順次、転記する方法を以下に示します。

Sub CopyData()
Dim myPath As String, myFile As String, myExtension As String
Dim FldrPicker As FileDialog
Dim x As Workbook, y As Workbook
Dim ws As Worksheet
Dim i As Integer, j As Integer

'フォルダ選択ダイアログを表示
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "フォルダを選択してください。"
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
myPath = .SelectedItems(1) & "\"
End With

'Active.xlsxを開く
Set y = Workbooks.Open(myPath & "Active.xlsx")

'各Excelファイルを開いてデータをコピーする
myExtension = "*.xls*"
myFile = Dir(myPath & myExtension)
Do While myFile <> ""
Set x = Workbooks.Open(myPath & myFile)
For Each ws In x.Worksheets
For i = 1 To 10
j = j + 1
y.Sheets(1).Cells(j, 1) = ws.Range("B12").Value
Next i
Next ws
x.Close False
myFile = Dir
Loop

'Active.xlsxを保存して閉じる
y.Save
y.Close

MsgBox "完了しました。"
End Sub

上記のコードをExcel VBAエディタに貼り付け、実行することで、同じフォルダにある複数のExcelファイルの各sheet1のB12セルの値をActive.xlsxのSheet1のセルのA1～A10に順次、転記することができます。フォルダ選択ダイアログが表示されるので、対象のフォルダを選択してください。また、Active.xlsxは事前に作成しておく必要があります。

（by 生成AI）

この回答へのお礼

ご回答ありがとうございます。
コードを実行した結果、実行時エラー　1004
アプリケーション定義またはオブジェクト定義エラーとなりました

お礼日時：2023/12/02 23:01