(VBA)複数のシートから一つのシートへ情報を集約させたい いつも大変お世話になっております。ご検討をお願いします。 ・転記先シート名:Sheet1 ・Sheet1のG列/K列へ、複数シートのA列14行/F行14行を集約させたい ・今まで複数シートの取り出し部分の1行上に「品番, 箱種, 収容数, 永久略番, 箱数, 納入数」のいずれかのキーワードがあったが、なくなってしまった ・複数シートの取り出し部分のA列14行は数字で14文字なので、「A列に数字で14文字のデータがあったらA列とF列から14行分取り出す」がしたい ↓↓今までのVBA↓↓ '全部に適用する宣言 Option Explicit Public wb1 As Workbook, wb2 As Workbook Public openFilePath As Variant Public ary1 As Variant, ary2 As Variant Sub 合体() Application.ScreenUpdating = False Set wb1 = ThisWorkbook Call ファイルを選択 Call 品番以前の行を消す_2 Application.ScreenUpdating = True End Sub Sub ファイルを選択() Dim oneFile As Variant Application.ScreenUpdating = False openFilePath = Application.GetOpenFilename(FileFilter:="Microsoft Excel ファイル,*.xls*", _ Title:="入力できるよう処理をするファイルを選んで下さい", MultiSelect:=True) '全部に適用してるopenFilePath End Sub 'コピーした品番や入荷数を、転記先に貼り付ける Sub 貼り付け() Dim i As Long, r1 As Long, r2 As Long, r3 As Long '転記処理 wb1.Activate With Worksheets("Sheet1") r1 = Cells(Rows.Count, "G").End(xlUp).Row + 1 r2 = Cells(Rows.Count, "K").End(xlUp).Row + 1 r3 = WorksheetFunction.Max(r1, r2) '転記先の最終行の大きい方 Cells(r3, "G").Resize(14, 1) = ary1 Cells(r3, "K").Resize(14, 1) = ary2 End With End Sub Sub 品番以前の行を消す_2() Dim tg As Range Dim i As Long For i = 1 To UBound(openFilePath) Workbooks.Open openFilePath(i) Set wb2 = ActiveWorkbook wb2.Activate Dim findary As Variant, ercount As Variant findary = Array("品*番", "箱*種", "収*容*数", "永*久*略*番", "箱*数", "納*入*数") '★キーワードがなくなってしまったので変更したい With Worksheets("Sheet1") Dim j As Long For j = 0 To UBound(findary) Set tg = Columns("A:F").Find(What:=findary(j), LookAt:=xlPart, MatchByte:=True) If tg Is Nothing Then ercount = ercount + 1 If ercount = 6 Then '6回失敗したら MsgBox "失敗しました" End If Else '1個でも見つかったら Range("A1").EntireRow.Insert Rows("1:" & tg.Row - 1).Delete Exit For End If Next j ary1 = .Range("A2:A15") ary2 = .Range("F2:F15") End With '開いているファイルを閉じる(ダイアログを表示させない) Application.DisplayAlerts = False ActiveWorkbook.Close savechanges:=False Call 貼り付け 'ここで貼り付け作動 Next i End Sub
Visual Basic