[[20230113144923]]　『複数ファイルを１個のファイルにまとめる方法』（イチゴパフェ）　ページの最後に飛ぶ

『複数ファイルを１個のファイルにまとめる方法』（イチゴパフェ）

複数ファイルを１個のファイルにまとめる方法
下記のマクロは複数Excelを１個のExcelにまとめるのに使用してます。
Sub 送状抽出は、普段別に使用しているマクロになります。
「送*状」を含むデータだけを抽出したくて途中に入れました。

しかし、データ自体は取得できるのですが
なぜか、１個目・２個目・３個目と張り付く行に空きができてしまいます
空く行数は平野用*.xlsxに元々ある行数分だけ空いてしまいます。
「送状抽出」を入れないで行えばそのままキレイに張り付きますがそれだとデータ重いので処理が止まってしまいます。
なぜそのような現象が起こるか分かる方が居ましたら助けて下さい。

Sub 五ファイル貼付()
Application.ScreenUpdating = False

 Dim desktop As String
 Dim ds As Worksheet
 Dim dr As Long
 Dim file As String
 Dim wb As Workbook
 Dim ws As Worksheet
 Dim lastRow As Long
 desktop = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
Set ds = ThisWorkbook.Sheets("Sheet2") '貼り付け先シート
ds.Cells.ClearContents '結果クリア
dr = 1 'コピー先行の初期値=1
 file = Dir(desktop & "平野用*.xlsx")
Do While file <> ""
Set wb = Workbooks.Open(desktop & file)
Set ws = wb.Sheets("Sheet1")
送状抽出
lastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
ws.Range("1:" & lastRow).Copy ds.Range("A" & dr)
dr = dr + lastRow
wb.Close False
file = Dir
Loop
End Sub

Sub 送状抽出()
Dim 検索文字 As String, 記憶 As String
記憶 = "送*状"
If IMEStatus = vbIMEModeOff Then

      SendKeys "{kanji}", True
End If
検索文字 = 記憶
記憶 = 検索文字
    検索文字 = StrConv(検索文字, vbWide)
    検索文字 = Application.WorksheetFunction.Substitute(検索文字, "＊", "*")
    Selection.AutoFilter Field:=36, Criteria1:="*" & 検索文字 & "*"
End Sub

＜使用 Excel：Microsoft365、使用 OS：Windows10 ＞

 もとのコードを生かすならdrの行番号を、dsシートの最終行の次の行に指定することで行けそうな気がするけど、どうかな？
 コピー元の先頭行が空白じゃない限り大丈夫だと思うけど・・・
    Sub 五ファイル貼付()
        Dim desktop As String
        Dim ds As Worksheet
        Dim dr As Long
        Dim file As String
        Dim wb As Workbook
        Dim ws As Worksheet
        Dim lastRow As Long
        desktop = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
        Set ds = ThisWorkbook.Sheets("Sheet2") '貼り付け先シート
        ds.Cells.ClearContents '結果クリア
        dr = 1 'コピー先行の初期値=1
        file = Dir(desktop & "平野用*.xlsx")
        Application.ScreenUpdating = False
        Do While file <> ""
            Set wb = Workbooks.Open(desktop & file)
            Set ws = wb.Sheets("Sheet1")
            Call 送状抽出
            lastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
            If dr > 1 Then
                dr = ds.Cells(Rows.Count, "A").End(xlUp).Offset(1)
            End If
            ws.Range("1:" & lastRow).Copy ds.Range("A" & dr)
            wb.Close False
            file = Dir
        Loop
        Application.ScreenUpdating = True
    End Sub
（稲葉） 2023/01/13(金) 15:10:21

試してないのでミスっているかもですが、例えば↓のように修正してはどうでしょうか？

    Sub 修正案()
        Dim ds As Worksheet
        Dim desktop As String
        Dim file As String
        Dim buf As Long
        Dim フラグ As Boolean

        Set ds = ThisWorkbook.Sheets("Sheet2") '貼り付け先シート
        ds.Cells.ClearContents

        desktop = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"

        file = Dir(desktop & "平野用*.xlsx")
        Do While file <> ""
            With Workbooks.Open(desktop & file).Sheets("Sheet1")
                .AutoFilterMode = False
                .Range("A1").AutoFilter Field:=36, Criteria1:="*送*状*"

                buf = ds.Cells(ds.Rows.Count, 37).End(xlUp).Row + 1

                Intersect(.AutoFilter.Range, .AutoFilter.Range.Offset(フラグ * -1)).Copy ds.Cells(buf, "B")
                ds.Range(ds.Cells(buf, "A"), ds.Cells(ds.Cells(ds.Rows.Count, 37).End(xlUp).Row, "A")).Value = file

                .Parent.Close False
                フラグ = True
            End With

            file = Dir()
        Loop

        ds.Rows(1).Delete
    End Sub

（もこな２） 2023/01/13(金) 15:39:43

稲葉様ありがとうございます。
なぜだか、１個のファイルが数行しか張り付かなったかです…
ちょっとテストをまだまだしてみるので月曜日にまたコメント書きます。
（イチゴパフェ） 2023/01/13(金) 17:44:36

もこな２さま、ありがとうございます。
完璧です！
しかも、２ファイル目はタイトル行も取れてる．．．ありがたい
ａ列にＥｘｃｅｌ名が入っているのはどこの部分なのでしょうか？
（イチゴパフェ） 2023/01/13(金) 17:45:49

もこな２様、

                buf = ds.Cells(ds.Rows.Count, 37).End(xlUp).Row + 1
                Intersect(.AutoFilter.Range, .AutoFilter.Range.Offset(フラグ * -1)).Copy ds.Cells(buf, "B")
                ds.Range(ds.Cells(buf, "A"), ds.Cells(ds.Cells(ds.Rows.Count, 37).End(xlUp).Row, "A")).Value = file
                .Parent.Close False

これはどういった処理なのでしょうか？
（イチゴパフェ） 2023/01/16(月) 14:59:33

■１
＞ａ列にＥｘｃｅｌ名が入っているのはどこの部分なのでしょうか？
【ステップ実行】してファイル名（【file】という変数に格納してますよね）を書き込んでいる箇所を調べてみてください。

■２
＞これはどういった処理なのでしょうか？
こちらも【ステップ実行】して確認された方がよいと思いますが、それぞれ

 ======================================================
 buf = ds.Cells(ds.Rows.Count, 37).End(xlUp).Row + 1
　　　 ↓
 【buf】という変数に、 ThisWorkbook.Sheets("Sheet2")のAK1048576セルから上に見ていき、
 最初にデータが入っている行の行番号+1を格納しなさい
 ======================================================
 Intersect(.AutoFilter.Range, .AutoFilter.Range.Offset(フラグ * -1)).Copy ～～
　　　 ↓
 オートフィルタが設定されているセル範囲と、オートフィルタが設定されているセル範囲（から１行下がった）セル範囲が
 重なる範囲（＝項目行を除いた、オートフィルタが設定されているセル範囲）をコピーしなさい
 ======================================================
 ～～ ds.Cells(buf, "B")
　　　 ↓
 ThisWorkbook.Sheets("Sheet2")のB列、[buf]行目に貼付しなさい
 ======================================================
 ds.Range(ds.Cells(buf, "A"), ds.Cells(ds.Cells(ds.Rows.Count, 37).End(xlUp).Row, "A")).Value = file
　　　 ↓
 ThisWorkbook.Sheets("Sheet2")のA列、[buf]行目～同シートのA列、
 ThisWorkbook.Sheets("Sheet2")のAK1048576セルから上に見ていき最初にデータが入っている行の行番号の行
 まで、【file】という変数の中身を書き込みなさい
 ======================================================
  .Parent.Close False
　　　 ↓
 Workbooks.Open(desktop & file).Sheets("Sheet1")の親（つまり、開いたブック）を閉じなさい

という命令になっています。

■３
いずれも、既に述べたようにまずは【ステップ実行】して動きを確認したり、わからない命令はネット検索してみてください。
それでもわからなければ、「×××について□□□と解釈しましたが、△△△とすると☆☆☆となってしまいます。」など具体的に聞くと、アドバイスが得られると思います。

なお、【ステップ実行】という言葉を聞いたことがなければ↓を読んでみてください。

 【ステップ実行】
https://www.239-programing.com/excel-vba/basic/basic023.html
http://plus1excel.web.fc2.com/learning/l301/t405.html

 【ブレークポイント】
https://www.239-programing.com/excel-vba/basic/basic022.html
https://www.tipsfound.com/vba/01010

 【イミディエイトウィンドウ】
https://www.239-programing.com/excel-vba/basic/basic024.html
https://excel-ubara.com/excelvba1/EXCELVBA486.html

 【ローカルウィンドウ】
https://excel-ubara.com/excelvba4/EXCEL266.html
http://excelvba.pc-users.net/fol8/8_2.html

（もこな２） 2023/01/27(金) 12:18:40

コメント返信：

[ 一覧(最新更新順) ]

[[20230113144923]] 『複数ファイルを１個のファイルにまとめる方法』（イチゴパフェ） ページの最後に飛ぶ

[[20230113144923]]　『複数ファイルを１個のファイルにまとめる方法』（イチゴパフェ）　ページの最後に飛ぶ