【VBA】複数のブックを1つのシートにまとめる

質問

あるフォルダ内に複数のブックが入っており、新しいブックに1シートでまとめようとしております。
フィルターを使用すればよいのかもしれませんが、マクロを使用したいです。

(1)全て同じフォーマットである
(2)全てA17から数値が入力されているので、16行目まではフォーマットを残し、A17行目以降K列までをコピーして結合したい

Sub 結合()

'結合したいファイルがあるフォルダの場所 cドライブなら "C:\test\"
Const Fol As String = "C:\test\"
Dim Fn
Dim NewFile As Workbook
Dim Wb As Workbook
Dim Ws1 As Worksheet

Dim R As Range
Set NewFile = Workbooks.Add
Set Ws1 = NewFile.Worksheets(1)

Set R = Ws1.Range("A17")
Fn = Dir(Fol, vbNormal)
Do Until Fn = ""
Set Wb = Workbooks.Open(Fol & Fn)

'ワークシート1をコピーする場合は Wb.Worksheets(1)
Set Ws1 = Wb.Worksheets(1)

'タイトル行を設定
If ck = False Then
For cnt = 1 To 4
Wb.Worksheets(cnt).Range("A1:J16").Copy Destination:=NewFile.Worksheets(cnt).Range("A1")
Next cnt
ck = True
End If
For cnt = 1 To 4
Set Ws1 = NewFile.Worksheets(cnt)
Set Ws2 = Wb.Worksheets(cnt)
R = Ws1.Cells(Rows.Count, 1).End(xlUp).Row + 1
With Ws2
End With
Next

'A17行目からコピーして結合する（→本当はA17行目～K列までを反映したい)
Ws2.Range("A17", Ws2.Cells(Rows.Count, 3).End(xlUp)).Resize(, 20).Copy R
If R.Offset(1).Value = "" Then
Set R = R.Offset(1)
Else
Set R = R.End(xlDown).Offset(1)
End If
Wb.Close

'Debug.Print Fn
Fn = Dir
Loop
Set R = Nothing
Set Ws1 = Nothing: Set Ws2 = Nothing
Set Wb = Nothing: Set NewFile = Nothing

End Sub

マクロは触ったことない初心者でグーグル検索をしながら作ってみました。
一応実行するとエラーは出ないのですが、結合されたリストが飛び飛びで、理由がわかりません。
どなたかおわかりになりますでしょうか・・・。

回答No.3

kkkkkm · ベストアンサー

> 既存4シート→4シートを各シートごとで結合

色々やりかたはあると思いますが、元のコードの

For cnt = 1 To 4
Set Ws1 = NewFile.Worksheets(cnt)
Set Ws2 = Wb.Worksheets(cnt)
R = Ws1.Cells(Rows.Count, 1).End(xlUp).Row + 1
With Ws2
End With
Next

の部分とその下の部分

Ws2.Range("A17", Ws2.Cells(Rows.Count, 3).End(xlUp)).Resize(, 20).Copy R
If R.Offset(1).Value = "" Then
Set R = R.Offset(1)
Else
Set R = R.End(xlDown).Offset(1)
End If

とを一部変更して合成します。

For cnt = 1 To 4
Set Ws1 = NewFile.Worksheets(cnt)
Set Ws2 = Wb.Worksheets(cnt)
'A17行目からコピーして結合する（→本当はA17行目～K列までを反映したい)
If Ws1.Cells(Rows.Count, 1).End(xlUp).Row < 17 Then
Set R = Ws1.Range("A17")
Else
Set R = Ws1.Cells(Rows.Count, 1).End(xlUp).Offset(1)
End If
Ws2.Range("A17", Ws2.Cells(Rows.Count, 3).End(xlUp)).Resize(, 20).Copy R
Set Ws1 = Nothing: Set Ws2 = Nothing
Next

> これを開かないようにすることはできますでしょうか？

以下のサイトを参考にしてください。

ブックを開かずにセル値を取得
https://excel-ubara.com/excelvba5/EXCELVBA242.html

ブックを開かないでセルのデータを読む
http://officetanaka.net/excel/vba/tips/tips28.htm

なお、余計な事だとは思いますが、変数宣言のないものがあったので、オプションで「変数の宣言を強制する」にしておいた方がいいと思います。

お礼

まさにやりたいことができました・・・！！
感謝しきれません。。
色々と教えて下さってありがとうございます。
今後も自分で組めるように学んでいこうと思います。
本当にありがとうございました。

回答No.2

kkkkkm

あと
If R.Offset(1).Value = "" Then
Set R = R.Offset(1)
Else
Set R = R.End(xlDown).Offset(1)
End If
ですが、コピーしたデータのA列の途中に空白があった場合そこから下は次回上書きされてしまいますが、空白がある可能性があるのでしたら以下のようにしておくといいのではないかと思います。
Set R = NewFile.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1)

あくまで、シート1にばかり既存のシート4をコピーしていくという事だとしたらですが。

補足

ご丁寧に記載くださりありがとうございます・・！！
教えていただいたコードに修正しましたらちゃんと起動しました！！
大変助かります。
ご質問に補足すると、既存のシート4をコピーというわけでなく、あくまで「既存シート1を新規ブックシート1に全て結合」と想定しております。

また、重ねて恐縮なのですが。。
(1)こちらのコードで実行すると、結合されたブックとは別にファイルに格納されている既存ブックが全て開かれて表示されます。
　これを開かないようにすることはできますでしょうか？(結合ブックのみを表示)

(2)今回は1シートの結合で作成してみましたが、4シート全て同じ動作をさせるとなると、難易度が高くなりまでしょうか？
　既存4シート→4シートを各シートごとで結合

なかなか同じようなサンプルが検索しても見当たらなかったので。。

回答No.1

kkkkkm

Ws2.Range("A17", Ws2.Cells(Rows.Count, 3).End(xlUp)).Resize(, 20).Copy R

この時点でWs2はWb.Worksheets(4)なのでシート(4)のデータをコピーしてると思いますが、とびとびとはどのような状態でコピーされているのでしょう。

ここは4回ループしてますが
For cnt = 1 To 4
Set Ws1 = NewFile.Worksheets(cnt)
Set Ws2 = Wb.Worksheets(cnt)
R = Ws1.Cells(Rows.Count, 1).End(xlUp).Row + 1
With Ws2
End With
Next

ループを抜けて設定されるのは
Set Ws1 = NewFile.Worksheets(4)
Set Ws2 = Wb.Worksheets(4)
R = Ws1.Cells(Rows.Count, 1).End(xlUp).Row + 1
だけのような気がします。
R.Valueもそのすぐ後に上書きされてるようですが…。