kir********

2021/1/22 11:52

33回答

Excelのマクロについて教えて下さい。

Excelのマクロについて教えて下さい。 所定のフォルダ(Cドライブ内のフォルダ１という名前)に複数のファイルを入れておいて、別のExcelでボタンを設置して押すと、そのフォルダ内のセルA2、C1、A4:C＊を抽出して、ボタンを設置したシートに画像のような形で一覧になるようなマクロを教えて欲しいです。A4:C＊の最終行の判断は、A列からC列全てがブランクの場合、その上の行までを抽出したいです。どなたか教えて頂けないでしょうか。

画像

Excel | Visual Basic・33閲覧・xmlns="http://www.w3.org/2000/svg">50

ベストアンサー

0

関数は苦手

カテゴリマスター

2021/1/22 15:58

一例です。参照設定で Microsoft Scripting Runtime を設定しておいてください。 Sub Sample() Dim tmp As String Dim f As File Dim r As Long Dim sh As Worksheet Dim fso As Scripting.FileSystemObject Application.ScreenUpdating = False Set fso = New Scripting.FileSystemObject '集約フォルダ tmp = "D:\Sample\test" '集約先 Set sh = ThisWorkbook.Sheets("Sheet1") For Each f In fso.GetFolder(tmp).Files If InStr(fso.GetExtensionName(f), "xls") Then Workbooks.Open f, ReadOnly:=True r = sh.Cells(Rows.Count, "C").End(xlUp).Offset(1).Row If r = 2 Then r = 1 sh.Cells(r, "A").Value = Range("A2").Value sh.Cells(r, "B").Value = Range("C1").Value Range("A4").CurrentRegion.Copy sh.Cells(r, "C") Workbooks(f.Name).Close False End If Next f Application.CutCopyMode = False Application.ScreenUpdating = True Set fso = Nothing MsgBox "Done." End Sub

画像

ThanksImg質問者からのお礼コメント

いつも回答頂き、ありがとうございます。 一番希望していた形の結果が得られました。感謝いたします。

お礼日時：1/25 15:00

その他の回答（2件）

0

tra********

カテゴリマスター

2021/1/23 15:56

新規ブックにコピーされます。 対象のブックのフォルダーは★、拡張子は◆のところを変更してください。 Sub sample() Dim xFile As String, sh0 As Worksheet, i As Long, sh As Worksheet Const cFld As String = "C:\HogeHoge\Hoge1\SAMPLE\" '★ Const cExt As String = "*.xlsx" '◆ Application.ScreenUpdating = False Set sh0 = Worksheets.Add i = 1 xFile = Dir(cFld & cExt) Do While xFile <> "" With Workbooks.Open(cFld & xFile) For Each sh In .Worksheets With sh sh0.Cells(i, 1).Resize(, 2).Value = Array(.Range("A2").Value, .Range("C1").Value) With .Range("A4").CurrentRegion .Copy sh0.Cells(i, 3) i = i + .Rows.Count End With End With Next sh .Close False End With xFile = Dir Loop With sh0.Range("A1").CurrentRegion .Borders.LineStyle = True .EntireColumn.AutoFit .Parent.Move End With Application.ScreenUpdating = True End Sub

kir********

質問者

2021/1/25 14:46

回答ありがとうござます！ やってみたところボタンを設置したSheet1と何もﾃﾞｰﾀの入っていないsheet2が消え、新たにsheet3が作られ、そこに集約された形になったのですが、 例えばsheet1にマクロのボタンを設置し sheet２に集約された結果が表示されるようにするには どうすれば良いのでしょうか？

0

gla********

2021/1/22 18:27

こんな感じです。コード長くなりました。 使う前の準備 ①[Microsoft Scripting Runtime]を参照設定してください。 ②データのあるフォルダを指定してください。 備考 ①配列数は100×20を設定しています。過不足がある場合は修正してください。分からない場合はそのままお使いください。 機能 ①指定フォルダ内の[.xlsx]ファイルをすべて処理します。 ※[.xlsx]を[.xls*]としてもかまいません。 ②ファイルのデータは全て配列に格納しています。 ③「NO」と「送付先」だけのデータの場合は、その２つだけを転記します。それ以外は全て出力します。 ④出力先はマクロファイルのSheet1です。 Sub test() Dim mypath As String Dim fso As New FileSystemObject Dim fl As Folder Dim f As File Dim wb As Workbook Dim ws As Worksheet Dim ary Dim ar As Variant, br As Variant Dim i, j, k, l As Long Dim m, n, p, q As Long Dim r, x As Long Application.ScreenUpdating = False Set wb = ThisWorkbook Set ws = wb.Worksheets("Sheet1") ar = Array("A2", "C1") 'データ取得先配列 br = Array("A", "B", "C") 'データ取得先配列 mypath = "C:\Users\○○\Desktop\△△" '##### データのあるフォルダを指定 ##### Set fl = fso.GetFolder(mypath) ReDim ary(100, 20) '## 配列(100行×20列分) ## m = 1 n = 1 For Each f In fl.Files If f.Name Like "*.xlsx" Then '[.xlsx]ファイルを対象(*.xls*でも良い) Workbooks.Open (f) r = Cells(Rows.Count, 1).End(xlUp).Row x = (r - 3) * 3 + 2 'コマ数制御 'データを配列格納(2次元) For i = 0 To UBound(ar) ary(m, n) = Range(ar(i)) n = n + 1 Next i For j = 0 To r - 4 For k = 0 To UBound(br) ary(m, n) = Range(br(k) & 4 + j) n = n + 1 If n > x Then Exit For Next k Next j m = m + 1 n = 1 ActiveWorkbook.Close End If Next '出力 wb.Activate With ws p = 0 '出力行数 q = 3 '3列目出力固定 For i = 1 To UBound(ary, 1) If ary(i, 1) = "" Then Exit Sub '[NO][送付先]出力 For j = 1 To 2 Cells(i + p, j) = ary(i, j) If j = 2 And ary(i, 3) = "" Then p = p + 1 Next j 'その他出力 l = 3 For k = 3 To UBound(ary, 2) If ary(i, l) = "" Then Exit For End If For l = k To UBound(ary, 2) Step 3 If ary(i, l) = "" Then Exit For Cells(i + p, q) = ary(i, l) Cells(i + p, q + 1) = ary(i, l + 1) Cells(i + p, q + 2) = ary(i, l + 2) p = p + 1 Next l Next k p = p - 1 Next i End With Application.ScreenUpdating = True End Sub

kir********

質問者

2021/1/25 14:54

回答ありがとうございます！出来ました！！ ただ、ボタンを設置したシートと集約した結果を 別シートにして分けたい場合はどうすればよいのでしょうか？ ボタン設置をシート１、 結果をシート２に表示させたいです。