マクロ EXCELの範囲をコピーして貼付け２

質問

【やりたいこと】
エクセルファイル（test.xls）に複数のシートが存在します。
（1）そのエクセルに新しいシートを1つ挿入しシート名を「統合」とつけます。
（2）シート名に「時」という文字が含まれたシートにある表を範囲指定しコピー
（3）「統合」シートに貼り付けます。
※「時」という文字が含まれたシートは複数あります（不特定）

【問題箇所（エラーになっている箇所）・・★】
「時」という文字が含まれたシートは複数枚あるので「統合シート」に貼付ける際
前に貼り付けた続きから貼り付けたいので「統合」シートの最終行を求め、
貼り付けを行っていきたいのですが、最終行を求める箇所でエラーになります。

度々の質問で申し訳ございませんがどなたかご教示頂けないでしょうか。
よろしくお願い致します。

Sub attendanceJoin()

Dim MaxRow As Integer
Dim wsNewMaxRow As Integer
Dim NewWorkSheet As Worksheet
Dim ws As Worksheet

Workbooks("test.xls").Activate
Set NewWorkSheet = Worksheets.Add() '新しいシートを追加
NewWorkSheet.Name = "統合" '新しく追加したシートに「統合」と名前をつける
Worksheets("統合").Range("A1").Value = "NO" 'A1のセルに「NO」と入れる

For Each ws In Worksheets

If ws.Name Like "*時*" Then
MaxRow = Worksheets(ws.Name).Range("A4").End(xlDown).Row
wsNewMaxRow = Worksheets("統合").Range("A1").End(xlDown).Row
'↑★この行でエラー：最終行を求める箇所

With Workbooks("test.xls")
.Worksheets(ws.Name).Range("A5:M" & MaxRow).Copy
.Worksheets("統合").Range("A" & wsNewMaxRow + 1).PasteSpecial
'求めた最終行の次から貼り付けする。

End With

End If

Next

End Sub

回答No.1

keithin · ベストアンサー

間違いのソノ１：
変数の宣言(Dim）をIntegerにしているからです。Longに変更します。

間違いのソノ２：
最初に統合のA1セルに「No」を記入した後，end(xldown)では間違いです。
実際に手を動かして，統合のA1のNoが入った状態からA1セルでCtrl+↓を押して，end命令の作動結果をエクセルを操って確認してみて下さい。

こんなカンジ：
sub macro1()
　dim wT as worksheet
　dim w as worksheet

　set wT = worksheets.add(after:=worksheets(worksheets.count))
　wt.name = "統合"
　wt.range("A1") = "No"

　for each w in worksheets
　　if w.name like "*時*" then
　　　w.range("A5:M" & w.range("A65536").end(xlup).row).copy _
　　　　destination:=wt.cells.specialcells(xlcelltypelastcell).offset(1).end(xltoleft)
　　end if
　next
end sub

お礼

ご丁寧にソースまで書いて頂きありがとうございました。
無事最終行から貼り付けすることができました。

早速のご回答に感謝申し上げます。
ありがとうございました。

回答No.2

o_chi_chi

１回目の統合シートには"A1"しかデータが入力されていないので

＞Worksheets("統合").Range("A1").End(xlDown).Row

を実行するとA1から検索するので最終行65536が帰ってきてしまいます。

wsNewMaxRowはIntegerなのでオーバーフローしてしまいます。

１回目はwsNewMaxRowに固定で1を入れるようにすればいいのでは。

お礼

早速のご回答ありがとうございます。
wsNewMaxRowは「65536」で帰ってきました・・・。

ご指摘ありがとうございました。
１回目のwsNewMaxRowを固定で「1」を入れるようにし無事できました。

ありがとうございました。