このマクロの間違いを教えて下さい。

締切済

質問者：たふあひ
質問日時：2021/05/11 23:42
回答数：3件

マクロ初心者で勉強中です。下記のようなマクロを書いたのですが、下に記載のところでエラーがでます。各シートの指定範囲（可変）をコピーし、集計シート貼りつけるマクロを作成しています。

どこが悪いのか教えて頂きたいです。

Sub matome公休105()
Dim i As Integer
Dim lRow As Long, lCol As Long, lRow2 As Long
Application.ScreenUpdating = False
'----全データシートの有無をチェックします
sh_check
'----列見出しをコピーします　　’見出しの範囲を指定　　どこにペーストするか指定
Worksheets(2).Range("I40:J40").Copy Worksheets(1).Range("A1")
For i = 2 To Worksheets.Count
With Worksheets(i)
'シート１の最終行を求める（最終行の次の行を求める）
lRow2 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
Worksheets(i).Select

　★★★「下記のところでエラーが出ます」★★★
　Range("I42").CurrentRegion.Resize([MATCH(1,0/(I42:I50<>""))], 2).Select

'シート１の最終行の次に貼り付ける

Selection.Copy
Worksheets(1).Cells(lRow2, 1).PasteSpecial (xlPasteValues)
　End With
Next i
Worksheets(1).Activate
Range("A1").Select
Application.ScreenUpdating = True
End Sub

下記のように単体でするとうまく動作します。
Sub test()
Worksheets("原本").Activate
Range("I42").CurrentRegion.Resize([MATCH(1,0/(I42:I50<>""))], 2).Select
End Sub

通報する

この質問への回答は締め切られました。

質問の本文を隠す

回答 (3件)

最新から表示
回答順に表示

参考程度に

No.3

回答者： Qchan1962
回答日時：2021/05/12 17:57

遅くなりました　＃２です

＞エラー発生した時は、そのシートの処理はとばして次のシートに移るとしたらどうなるでしょうか。
On Error Resume Nextの場合、

Selection.Copy
Worksheets(1).Cells(lRow2, 1).PasteSpecial (xlPasteValues)
が実行されてしまいますね。（誤動作）

なので結局
On Error Resume Next
Range("I42").CurrentRegion.Resize([MATCH(1,0/(I42:I50<>""))], 2).Select
If Err.Number = 0 Then
Selection.Copy
Worksheets(1).Cells(lRow2, 1).PasteSpecial (xlPasteValues)
End If
On Error GoTo 0
　End With
Next i
こんな感じになってしまいます。

＃２のようにエラーでラベルに飛ばすのもエラーになっているか確かめて処理するにしても、内部的にはエラーが出力されている事には変わりませんね
なので[MATCH(1,0/(I42:I50<>""))]の代わりの処理を追加して
セルの拡張行数を取得するか、
MATCHのエラーの原因をあらかじめ調べてエラーが出る条件なら処理を
行わないようにする　などが考えられます。

[MATCH(1,0/(I42:I50<>""))]の代わりテスト用
Sub a()
Dim n As Integer, cnt As Integer
'コピー範囲の最大数を取得
cnt = .Range("I42:I50").Cells.Count
'コピー範囲I42:I50に値があるか調べる
For n = 50 To 42 Step -1
If .Cells(n, "I") <> "" Then
Exit For '値が有ればforを抜ける
End If
cnt = cnt - 1 'ループごとにセル範囲を-1する
Next
MsgBox ("cnt =" & cnt & " MATCH =" & [MATCH(1,0/(I42:I50<>""))])
End Sub

この　cnt　を組み不要部分を添削すると

Sub matome公休105()
Dim i As Integer
Dim lRow As Long, lCol As Long, lRow2 As Long
Dim n As Integer, cnt As Integer
Application.ScreenUpdating = False
'----全データシートの有無をチェックします
'sh_check
'----列見出しをコピーします　　’見出しの範囲を指定　　どこにペーストするか指定
Worksheets(2).Range("I40:J40").Copy Worksheets(1).Range("A1")
For i = 2 To Worksheets.Count
With Worksheets(i)
'シート１の最終行を求める（最終行の次の行を求める）
lRow2 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
' Worksheets(i).Select これは Withで纏めているので無くて良いが
' Worksheets(i)に対してのレンジオブジェクトは　.　を加える（下記参照）
'コピー範囲の最大数を取得
cnt = .Range("I42:I50").Cells.Count
'コピー範囲（）に値があるか調べる
For n = 50 To 42 Step -1
If .Cells(n, "I") <> "" Then
Exit For '値が有ればforを抜ける
End If
cnt = cnt - 1 'ループごとにセル範囲を-1する
Next
'すべて空白セルなら実行しない（セル範囲が0）
If cnt > 0 Then
'シート１の最終行の次に貼り付ける
.Range("I42").Resize(cnt, 2).Copy
Worksheets(1).Cells(lRow2, 1).PasteSpecial (xlPasteValues)
'最後のシートのコピー範囲に点々が残るので下記を追加
Application.CutCopyMode = False
End If
End With
Next i
Worksheets(1).Activate
Range("A1").Select
Application.ScreenUpdating = True
End Sub

.CurrentRegion　リサイズしてしまうので要を足さないような・・？

'----全データシートの有無をチェックします
部分もあるかと思いますので先が長いのかもしれませんが、
参考になりますでしょうか。

- 0
- 件

通報する

参考程度に

No.2

回答者： Qchan1962
回答日時：2021/05/12 01:44

こんばんは、

インデックス2以降のすべてのシートで
I42:I50セル範囲すべてが空白になっているシートはありませんか？

[MATCH(1,0/(I42:I50<>""))]は該当がない場合エラーが返りますので
エラートラップを配置するか、別の方法で範囲拡張数を取得する
必要があるように思います

簡単なエラートラップ
Worksheets(i).Select

On Error GoTo MyErr
　★★★「下記のところでエラーが出ます」★★★
Range("I42").CurrentRegion.Resize([MATCH(1,0/(I42:I50<>""))], 2).Select
'シート１の最終行の次に貼り付ける
Selection.Copy
Worksheets(1).Cells(lRow2, 1).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
MyErr:
On Error GoTo 0
End With

エラートラップが嫌な場合、例えば
If Application.CountIf(Range("I42:I50"), "<>") > 0 Then
などで値の有無をあらかじめ検証して問題部分を実行するなどが考えられますが、セルの値が　""(数式セル)になっている場合、CountIf　"<>"は通ってしまいますが、MATCHはエラーになると思われますので、対象セルに数式が入っている場合は、正しく""を取得する（除外する）方法などの検討が必要かと思います。