VBAマクロで任意のエクセルファイルから、必要データを抽出

共有上にあるエクセルファイルから別のエクセルファイルにデータを抽出したいときマクロ（設定シートにファイルパスなど入れておく）を利用すると便利

ファイルパスは、以下のようなマクロで取得
Sub sansho() Dim fType, prompt As String Dim fPath As Variant Dim ws As Worksheet Set ws = Worksheets("設定") '選択できるファイルの種類をxlsに限定 fType = "Excel ﾌｧｲﾙ (*.xlsx),*.xlsx" 'ダイアログのタイトルを指定 prompt = "Excelファイルを選択して下さい" 'ファイル参照ダイアログの表示 fPath = Application.GetOpenFilename(fType, , prompt) If fPath = False Then 'ダイアログでキャンセルボタンが押された場合は処理を終了します End End If 'B2セルにファイル名をセット ws.Cells(3, 1).Value = fPath End Sub  
データのコピー処理は以下のようなマクロで Sub Macro1() ' ' Macro1 Macro ' 'コピー元のシートがあるファイルを開く fPath = Workbooks(ThisWorkbook.Name).Worksheets("設定").Range("A3") fff = Split(fPath, "\") fn = fff(UBound(fff)) MsgBox (fn) Workbooks.Open (fPath) kyokasitei = Workbooks(ThisWorkbook.Name).Worksheets("設定").Range("A8") Workbooks(ThisWorkbook.Name).Worksheets("List").Cells.ClearContents ' cou = 0 For Each i In Workbooks(fn).Sheets 'Debug.Print i.Name Sheets(i.Name).Select 'MsgBox (i.Name) For j = 0 To 4 ' j:列方向 dt = Cells(4, 2 + j * 3).Value For k = 0 To 4 ' k:行方向 If k < 2 Then Kyoka = Cells(10 + k * 4, 2 + j * 3).Value Title = Cells(10 + k * 4, 4 + j * 3).Value Naiyo = Cells(11 + k * 4, 4 + j * 3).Value Naiyo2 = Cells(12 + k * 4, 4 + j * 3).Value Else Kyoka = Cells(10 + k * 3 + 1, 2 + j * 3).Value Title = Cells(10 + k * 3 + 1, 4 + j * 3).Value Naiyo = Cells(11 + k * 3 + 1, 4 + j * 3).Value Naiyo2 = Cells(12 + k * 3 + 1, 4 + j * 3).Value End If 'MsgBox (Title): End If Naiyo <> "" And (kyokasitei = Kyoka Or kyokasitei = "") Then Call shori(Workbooks(ThisWorkbook.Name), dt, Kyoka, Title, Naiyo, Naiyo2, cou) cou = cou + 1 End If On Error Resume Next Next k Next j Next i 'コピー元ファイルを閉じる Workbooks(fn).Close MsgBox ("終了") End Sub Sub shori(wb As Object, ByVal dt As Date, ByVal Kyoka As String, ByVal Title As String, ByVal Naiyo As String, ByVal Naiyo2 As String, ByVal cou As Integer) wb.Worksheets("List").Cells(cou + 1, 1).Value = dt wb.Worksheets("List").Cells(cou + 1, 2).Value = Kyoka wb.Worksheets("List").Cells(cou + 1, 3).Value = Title wb.Worksheets("List").Cells(cou + 1, 4).Value = Naiyo wb.Worksheets("List").Cells(cou + 1, 5).Value = Naiyo2 End Sub