複数ブック、指定条件つき結合

投稿者 : いい     投稿日時 : 2024/10/17(Thu) 18:42:38     OS : Windows 11     EXCEL : Excel 2019

---

以下のVBAを組みたいのですが、どうすれば良いかわからずご協力いただきたいです

●やりたい事(流れ)

・1つのフォルダに複数のExcelブック有
　フォルダ＿リスト1.xlsx
　　　　　＿リスト2.xlsx
　　　　　＿リスト3.xlsx
　　　　　＿リスト4.xlsx
　　　　　　・・・・

・リスト内の指定した行数を別ブックに移動させたい
　例「10行と設定」

　⑴リスト1.xlsx　1～10行→新ブックAにコピー
　⑵リスト2.xlsx　1～10行→⑴のコピーした下にコピー
　⑶リスト3.xlsx　1～10行→⑵のコピーした下にコピー
　⑷リスト4.xlsx　1～10行→⑶のコピーした下にコピー
　⑸リスト1.xlsx　11～21行→⑷のコピーした下にコピー
　⑹リスト1.xlsx　11～21行→⑸のコピーした下にコピー
　…リスト内のデータが無くなったら完了

・最終
　1つのExcelブックになる

・補足
　リスト内の最終行はブックことに異なる

投稿者 : さんこう     投稿日時 : 2024/10/17(Thu) 20:24:07

---

＞以下のVBAを組みたいのですが、どうすれば良いかわからず

まずは、行数を無視して、すべてまとめるようにしてみてはいかがでしょうか。

＜vba フォルダ内のブックからコピー＞
https://www.google.com/search?q=vba+%E3%83%95%E3%82%A9%E3%83%AB%E3%83%80%E5%86%85%E3%81%AE%E3%83%96%E3%83%83%E3%82%AF%E3%81%8B%E3%82%89%E3%82%B3%E3%83%94%E3%83%BC

それができたら、各ファイル１０行ずつまとめるように修正しましょう。

あとは、それを繰り返すようにしていくとよろしいかと思います。

投稿者 : てらてら     投稿日時 : 2024/10/18(Fri) 05:19:07

---

こんにちは。

最初のブックの値は、そのまま転記。
次からは、10行づつコピーして該当する位置に差し込んでいきます。
コピーする位置、コピー先の特定が面倒ですが、Debug.Print でもあてて観察してみてください。

最後に、空白行が差し込まれるので削除してます。

シート指定が無いので、"Sheet1"のみを対象としています。

Sub macro()
    Dim wb As Workbook
    Dim fname As String
    Dim i As Long
    Dim myWb As Workbook
    Set myWb = ThisWorkbook
    
    '最初のブックを転記
    Set wb = Workbooks.Open(ThisWorkbook.Path & "\フォルダ\リスト1.xlsx")
    wb.Worksheets("Sheet1").Range("A1").CurrentRegion.Copy myWb.Worksheets("Sheet1").Range("A1")
    wb.Close
    
    Dim t As Long, a As Long, pos As Long, s As Long
    
    For i = 2 To 4  'ファイルの数だけ繰返す
        fname = "リスト" & i & ".xlsx"
        Set wb = Workbooks.Open(ThisWorkbook.Path & "\フォルダ\" & fname)
        
        a = i - 1
        
        For t = 0 To 1000
            pos = (10 * a) + t * (10 * (a + 1))
            s = t * 10 + 1
            wb.Worksheets("Sheet1").Rows(s & ":" & s + 9).Copy
            myWb.Worksheets("Sheet1").Rows(pos + 1).Insert
            Application.CutCopyMode = False
            
            If wb.Worksheets("Sheet1").Cells(s, "A") = "" Then Exit For
        Next t
        wb.Close

    Next i
    
    '後始末
    With myWb.Worksheets("Sheet1")
    For i = .Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1
        If .Cells(i, "A") = "" Then
            .Rows(i).Delete
        End If
    Next i
    End With
    
End Sub