プロが教える店舗&オフィスのセキュリティ対策術

お世話になります。同内容で質問済ですが、私の力不足で教えて頂いたソースコードでエラーを回避することができず(ご回答者様大変申し訳ございません!!)、急ぎでツールを作らな得ればいけない関係上、自分で読解可能な使えそうなソースコードを拾いました。(以下がそのコード ★箇所アレンジ済エラー中)

見出しがマージされているためか、データ範囲の指定がうまくできません。
また、このソースは1シートしかない前提なのですが、これを複数シートでシートごとにマージするようにアレンジする場合は、どのように書き足せばよいでしょうか?


やりたいこと
ユーザーにフォルダを指定してもらいそのフォルダ内のブックをシートごとに統合する
(フォルダ指定のソースコードは完成しております。)
シートは7つ1つは統合不要で、残り6つのシートのデータをマージしたいです。
シート見出しが1-3行が不規則にマージされております。列のマージはありません。(画像添付)
列はALまであります。
レコードが存在するはいつもA4からはじまり、行に抜けはありません。
レコードが0の場合もあります。
1つのブックの1つのシートの最大レコード数はあっても1000くらいです
ファイルはすべて.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

「Excel VBA 複数ブックシートごと」の質問画像

質問者からの補足コメント

  • つらい・・・

    上記ソースコードの拾い先 YouTubeです

    「エクセル VBA 57 複数ブックデータを一つにまとめる処理について詳しく解説します! Dir関数についても説明あり。」

      補足日時:2022/05/20 14:38

A 回答 (4件)

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


Loop Until fileName = ""
Application.ScreenUpdating = False

Loop Until fileName = ""
Application.ScreenUpdating = True
ですね
    • good
    • 2
この回答へのお礼

ありがとうございます!!

お礼日時:2022/05/21 18:17

そちらですね


一旦、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
    • good
    • 4
この回答へのお礼

ご回答誠にありがとうございます!!

お礼日時:2022/05/21 18:17

こんにちは



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

>★箇所アレンジ済エラー中
「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行分を設定することができます。
(以降の処理で、空白行をコピーすることにはなりますが・・)

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

ご回答誠にありがとうございます。やってみます!!

お礼日時:2022/05/21 18:16

こんにちは


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

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

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

ご回答ありがとうございます!!

お礼日時:2022/05/20 16:30

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!