前提・実現したいこと
VBAでデータを抽出したいと考えております。
データ元のブックは同じフォルダ内にあり、複数のシートで構成されています。
データ元のシートの詳細な内容ですが、
①H4セルに特定の文字が入力されています
②8行目から下に、B列とM列にデータが入力されています
③各シートのフォーマットは同じですが、シートによってはB列とM列のデータが8行目のみの場合や、
複数行の場合もあります
④B列とM列のデータが複数行の場合、特定色でセルが塗りつぶされた行と塗りつぶしなしの行があります
上記の条件で、抽出したいのはデータ元の各シートのB列とM列の8行目以降で、
且つ、塗りつぶしのない行のデータのみです。
集計先では、H4セルの内容をそのままC5から下に貼り付けしていき、
B列のデータを集計先ブックのE5から下に、M列のデータをF5から下に貼り付けていきます。
データ元のシートでデータが複数行ある場合は、H4セルの内容も同じ数だけ、
集計先ブックのC列に貼り付けていきたいと思っています。
VBA初心者ですが、近々に業務で必要になり困っています。
お力添えをお願いいたします。
発生している問題・エラーメッセージ
各シートへのループが進まず、1つ目のシートの8行目のデータのみが集計先ブックに出力されます。
該当のソースコード
VBA
1 2Sub データ取り込み() 3 Dim myPath As String 4 Dim myFile As String 5 Dim FromBook As Workbook 6 Dim ToSheet As Worksheet 7 Dim CurRow As Long 8 Dim EndRow As Long 9 Dim i As Integer 10 Dim MaxRow As Integer 11 Dim j As Long 12 13 Set ToSheet = ThisWorkbook.Worksheets("Sheet1") ' 14 myPath = ThisWorkbook.Path & "\" 15 myFile = Dir(myPath & "*.xls?") 16 17 Application.ScreenUpdating = False 18 19 CurRow = 5 20 Do Until myFile = "集計.xlsm" 21 Set FromBook = Workbooks.Open(myPath & "\" & myFile) 22 For i = 1 To FromBook.Worksheets.Count 23 With FromBook.Worksheets(i) 24 ActiveSheet.Range("$B$6:$DE$11").AutoFilter Field:=1, Operator:=xlFilterNoFill 25 EndRow = .Cells(6, 2).End(xlDown).row 26 For j = 8 To EndRow 27 Cells(4, "H").Copy Destination:=ToSheet.Cells(CurRow, 3) 28 Cells(j, "B").Copy Destination:=ToSheet.Cells(CurRow, 5) 29 Cells(j, "M").Copy Destination:=ToSheet.Cells(CurRow, 6) 30 j = j + 1 31 Next j 32 33 End With 34 35 CurRow = CurRow + 1 36 37 Next i 38 39 Application.DisplayAlerts = False 40 FromBook.Close 41 myFile = Dir() 42 Loop 43 44 Application.ScreenUpdating = True 45 46 MaxRow = Cells(Rows.Count, 3).End(xlUp).row 47 Range(Cells(5, 3), Cells(MaxRow, 6)).Borders.Weight = xlMedium 48 Range(Cells(5, 3), Cells(MaxRow, 6)).Borders.ColorIndex = 16 49 Range(Cells(5, 3), Cells(MaxRow, 3)).HorizontalAlignment = xlCenter 50 Range(Cells(5, 5), Cells(MaxRow, 5)).HorizontalAlignment = xlCenter 51 Range(Cells(5, 6), Cells(MaxRow, 6)).HorizontalAlignment = xlCenter 52 53 MsgBox "取り込み完了しました。" 54End Sub 55
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。