Excel VBA 複数ブックシートごとにデータを統合する方法について

Question

お世話になります。同内容で質問済ですが、私の力不足で教えて頂いたソースコードでエラーを回避することができず（ご回答者様大変申し訳ございません！！）、急ぎでツールを作らな得ればいけない関係上、自分で読解可能な使えそうなソースコードを拾いました。（以下がそのコード　★箇所アレンジ済エラー中）

見出しがマージされているためか、データ範囲の指定がうまくできません。
また、このソースは1シートしかない前提なのですが、これを複数シートでシートごとにマージするようにアレンジする場合は、どのように書き足せばよいでしょうか？


やりたいこと
ユーザーにフォルダを指定してもらいそのフォルダ内のブックをシートごとに統合する
（フォルダ指定のソースコードは完成しております。）
シートは７つ１つは統合不要で、残り６つのシートのデータをマージしたいです。
シート見出しが1－3行が不規則にマージされております。列のマージはありません。（画像添付）
列はALまであります。
レコードが存在するはいつもA4からはじまり、行に抜けはありません。
レコードが０の場合もあります。
1つのブックの１つのシートの最大レコード数はあっても１０００くらいです
ファイルはすべて.xlsxです。


Sub データ処理()
Dim matomesh As Worksheet, scorewb As Workbook
Set matomesh = Worksheets("まとめ")
Dim fileName As String
fileName = Dir(ThisWorkbook.Path & "\*.xlsx")

If fileName <> "" Then
Dim sh As Worksheet
Dim lastrow As Long
Dim rng As Range
lastrow = matomesh.Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
Do
Set scorewb = Workbooks.Open(fileName:=ThisWorkbook.Path & "\" & fileName)
Set sh = scorewb.Worksheets("sheet1")
Set rng = sh.Range("A1").CurrentRegion.Offset(3, 0).Resize(sh.Range("A1").CurrentRegion.Rows.Count - 3) '★1
lastrow = matomesh.Cells(Rows.Count, 1).End(xlUp).Row
rng.Copy matomesh.Cells(lastrow + 1, 1) '★2
scorewb.Close savechanges:=False
fileName = Dir()
Loop Until fileName = ""
Application.ScreenUpdating = False
Else
MsgBox "データがありません"
End If
End Sub

Qchan1962 · Accepted Answer

そちらですね
一旦、sh.Range("A1").CurrentRegionをセットしてその大きさで操作すれば良さそう・・難しい回答ばかりで判らないと思いますので

エラーが出たら飛ばす・・なんて方法で期待通りの結果が得られるなら下記のようにすればOK？かな

Sub データ処理()
    Dim matomesh As Worksheet, scorewb As Workbook
    Set matomesh = Worksheets("まとめ")
    Dim fileName As String
    fileName = Dir(ThisWorkbook.Path & "\*.xlsx")
    If fileName <> "" Then
        Dim sh As Worksheet
        Dim lastrow As Long
        Dim rng As Range
        lastrow = matomesh.Cells(Rows.Count, 1).End(xlUp).Row
        Application.ScreenUpdating = False
        Do
            Set scorewb = Workbooks.Open(fileName:=ThisWorkbook.Path & "\" & fileName)
            Set sh = scorewb.Worksheets(1)
            On Error Resume Next
            Set rng = sh.Range("A1").CurrentRegion.Offset(3, 0).Resize(sh.Range("A1").CurrentRegion.Rows.Count - 3)        '★1
            lastrow = matomesh.Cells(Rows.Count, 1).End(xlUp).Row
            rng.Copy matomesh.Cells(lastrow + 1, 1)        '★2
            scorewb.Close savechanges:=False
            Err.Number = 0
            Set rng = Nothing
            fileName = Dir()
        Loop Until fileName = ""
        Application.ScreenUpdating = False
    Else
        MsgBox "データがありません"
    End If
End Sub

Qchan1962 · Answer

コピペで書いたので良く見ませんでした
Loop Until fileName = ""
Application.ScreenUpdating = False
は
Loop Until fileName = ""
        Application.ScreenUpdating = True
ですね

fujillin · Answer

こんにちは

ご説明の文章とコードの内容が必ずしも一致しているとは思えませんけれど、ひとまず、コードの方を正として考えました。

＞★箇所アレンジ済エラー中
「Range("A1").CurrentRegion」で目的とするセル範囲を取得できるものと仮定します。
エラーが発生する時は、4行目以降にデータがない（あるいは4行目が空白など）ではないでしょうか？

無条件で、sh.Range("A1").CurrentRegion.Rows.Count - 3 を指定しているので、0行以下になるときにエラーになっているのではないかと想像します。
それを回避するなら、
　Set rng = sh.Range("A1").CurrentRegion.Offset(3, 0)
　Set rng = rng.Resize(Application.Max(rng.Rows.Count - 3, 1))
などとしておくことで、データがない時は空白1行分を設定することができます。
（以降の処理で、空白行をコピーすることにはなりますが・・）

あるいは、行数を判断して、データがない時には、コピー処理までをスキップする制御に変更するのでも良いと思います。
（こちらの方法の方が、本筋と言えるかもしれません）

Qchan1962 · Answer

こんにちは
エラー№は？
添付画像の場合、エラーは出そうもありませんが
A1セルを囲むセルが空白の場合、CurrentRegionは取得できないので
1004エラーが返るかと
もし、そのようなシート表組も対象にしなければならない場合は、
データー群の必ず値が存在するセルを指定します。
上3行見出しを不要とする場合、必ずなら良いですが、それも不確定であれば
確定要素を考え範囲を決めるようにすれば良いでしょう。

★1でエラーが発生しなければ★２は実行可能と思います。

A1セルを囲むセルが空白になっていない時でもエラーが発生するのなら
エラー番号と発生するシートの画像を表示すると判り易いかもです

Excel VBA 複数ブックシートごとにデータを統合する方法について

そちらですね

コピペで書いたので良く見ませんでした

こんにちは

こんにちは

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング