Myu: VBA

2020年7月10日金曜日

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