条件が一致時の転記マクロの実行時エラーの対処

質問

いつもお世話になっております。

このサイトで転記するマクロを相談させて頂いたところ
コードを教えてもらい　そのコードを使用していたのですが
大元のエクセルのブックのセルの配置が変わる運用になり
それに伴いマクロを修正を行っていたのですが
実行時エラー"1004"
アプリケーション定義またはオブジェクト定義のエラーでマクロが動きません
コードのデバック部分はわかっていますが
色々と修正を試しましたが上手くいきません。

構成図とコードを書かせて頂きます
確認して頂いてもよろしいでしょうか？

転記先のＩＤ管理票.xls
このエクセルは別のマクロを組んでいて
メールと連動していてメール受信後、自動で
Ａ列　Ｂ列　Ｃ列に次から次へとデータがのってきます
このエクセルは原本のためマクロを更に追加したり
行を消したりふやしたりはできないです。
（マクロでF列を作業列として使用は可能です）

Ｄ列以降は空白です。
Ｅ列にＩＤデータ.xlsに記述した項目ごとのシートを確認して
文言を手作業で入力
文言は　「確認」　「払出」　「保留」　「取下」　「転記」　「再確認」

Ａ列の横は20000から始まっていますが過去のデータ3か月分乗っているので
データ量が行6から行20000以降続いています
当初は行1から始まっていたのですが仕様変更に伴い
行５から始まっています

列番号　　 Ａ列 　　　　　　　B列 　　　　C列 　D列 　E列
１　　
2
3
4
5 日時　　　　　　　件名 　　　　　処理　　　　　　区分
6　　2014/11/19 18:13:11　19001236　　 新規　　　　　　 確認
7 2014/11/19 18:33:08　19001237　　 修正　　　　　　 払出
8 2014/11/19 18:33:09　19001238　　 修正　　　　　　 転記
9 2014/11/19 18:33:08　19001237　　 修正　　　　　　 保留
10 2014/11/19 18:33:08　19001237　　 修正　　　　　　 取下
11 2014/11/19 18:33:08　19001237　　 準備　　　　　　
12 2014/11/19 18:33:08　19001237　　 準備　　　　　　
12 2014/11/19 18:33:08　19001237　　 修正　　　　　　 確認

↓
ずっと2万行まで続いています

・Ａ列にＩＤを受領した時間が記述
　時間帯はバラバラです。

・Ｂ列にＩＤ番号が記載
　同じ番号続いたりします。

・Ｃ列はＩＤの区分の新規.修正,準備が入ります

・Ｄ列は空白

・Ｅ列に確認項目を入力します 現状　
　最初の時は空白で、ＩＤデータ.xlsのシートに時間とＩＤと区分を記述して
　ＩＤデータ.xlsのシートを確認して手作業で入力

　文言は　「確認」　「払出」　「保留」　「取下」　「転記」　「再確認」
尚、C列に「準備」と項目があればE列も空白です

転記元のＩＤデータ.xls

シートが転記先のＩＤ管理票.xlsの入力する文言
ＩＤ管理票.xlsのＤ列の文言ごとにシートが分かれています
「確認」　「払出」　「保留」　「取下」　「転記」　「再確認」の５つのシートで分かれている

　　　　確認のシート
列番号　　　 Ａ列　　　　　　　　　　　　B列 　　　C列　　　E列　　
1　 2014/11/19 18:13:11　　　　 19001236　　 新規　　締切案件

　　　　　　払出のシート
列番号　　　 Ａ列　　　　　　　　　　B列 　　　　　　C列　　D列
1 　　 　2014/11/19 18:33:08　　　19001237　　修正　　確認案件　　　　
2　 　 　2014/11/19 18:33:06 　　19001237　　 修正　　延期案件

　　　保留のシート　　　　　　　　　　　
列番号　　　 Ａ列　　　　　　　　　　B列 　　　C列　　　　D列　
1 　　 2014/11/19 17:23:11 　19001239　　 修正　　　見直し

取下のシート
列番号　　　 Ａ列　　　　　　　　B列 　　　　C列　　　　D列
1 　　 2014/11/19 17:23:11 19001239　　 修正　　　　再度提出　　　

　　　　　　　　転記のシート
列番号　　　 Ａ列　　　　　　　　B列 　　　　　C列　　　D列
1 　　 　2014/11/19 17:23:11 19001240　　 修正　

　　　　再確認のシート
列番号　　　 Ａ列　　　　　　　　B列 　　　　C列　　　D列
1 　　2014/11/19 17:23:11 19001241　　 修正

やりたいことは
ＩＤデータ.xlsの方にマクロを組み込んで
ＩＤ管理票のＤ列に
時間とＩＤが一致したものを
文言（「確認」　「払出」　「保留」　「取下」　「転記」　「再確認」　の５つの項目）を転記

この条件でコードを書いていただいたのですが
エクセルの内容が変わったために上手く動いていません

実行時エラー"1004"
アプリケーション定義またはオブジェクト定義のエラー

lastRow6 = wS2.Cells(Rows.Count, "A").End(xlUp).Row

ここでデバックでています。
下記が書いていただいたコードを環境に合わせて書き換えた状態です。
確認して頂いてもよろしいでしょうか？
お忙しい中、お手数ですがよろしくお願いいたします

Sub ○○()
Dim i As Long, k As Long, lastRow1 As Long, lastRow2 As Long
Dim wS1 As Worksheet, wS2 As Worksheet
Application.ScreenUpdating = False
Set wS2 = Workbooks("ID管理票.xls").Worksheets(1)

lastRow6 = wS2.Cells(Rows.Count, "A").End(xlUp).Row

Range(wS2.Cells(2, "F"), wS2.Cells(lastRow2, "F")).Formula = "=A6&""_""&B6"

With ThisWorkbook
For k = 3 To .Worksheets.Count
Set wS1 = .Worksheets(k)
lastRow1 = wS1.Cells(Rows.Count, "A").End(xlUp).Row

If lastRow1 > 1 Then
Range(wS1.Cells(2, "E"), wS1.Cells(lastRow1, "E")).Formula = "=A6&""_""&B6"

For i = 6 To lastRow6
wS2.Rows(1).AutoFilter field:=6, Criteria1:=wS1.Cells(i, "E")
If wS2.Cells(Rows.Count, "A").End(xlUp).Row > 1 Then
Range(wS2.Cells(2, "E"), wS2.Cells(lastRow2, "E")). _
SpecialCells(xlCellTypeVisible) = wS1.Name
End If
Next i

wS1.Range("E:E").ClearContents
End If
Next k
End With

wS2.AutoFilterMode = False
wS2.Range("F:F").ClearContents
Application.ScreenUpdating = True
End Sub

回答No.1

tom04 · ベストアンサー

こんばんは！
前回回答した者です。

＞lastRow6 = wS2.Cells(Rows.Count, "A").End(xlUp).Row

lastRow6　は変数の宣言をしていませんので、当然エラーとなるはずです。
尚、当方の変数の宣言のやり方が判り難いのでこのようなコトになると思いますが、
もう一度コードを訂正して載せてみます。

尚、今回は「管理票Sheet」は5行目が項目行でデータは6行目以降にあるのですね。
そして、各Sheet（5種類）は質問文を拝見するとDもしくはE列まで何らかのデータが入っているようですので、
今回はF列を作業用の列としてみました。（前回はD列が作業用の列）

↓のコードで試してみてください。
（コード内の★印の行が変更で、若干の説明を加えています）

Sub Sample3()
Dim i As Long, k As Long, lastRow1 As Long, lastRow2 As Long
Dim wS1 As Worksheet, wS2 As Worksheet
Application.ScreenUpdating = False
Set wS2 = Workbooks("ID管理票.xls").Worksheets(1)
lastRow2 = wS2.Cells(Rows.Count, "A").End(xlUp).Row '★lastRow2　は「ID管理票Sheet1」の最終行
'▼「ID管理表票Book」のシート1、C～E列データ消去
If lastRow2 > 1 Then
Range(wS2.Cells(6, "C"), wS2.Cells(lastRow2, "C")).ClearContents '★「lastRow2」はそのまま
Range(wS2.Cells(6, "E"), wS2.Cells(lastRow2, "E")).ClearContents '★「lastRow2」はそのまま
End If
'▼「ID管理票、シート1」のF列を作業用の列として使用
Range(wS2.Cells(6, "F"), wS2.Cells(lastRow2, "F")).Formula = "=A6&""_""&B6" '★「ID管理票Sheet」のF6～F列最終行の・・・
'▼「IDデータBook」のシート1～最終シートまでループ
With ThisWorkbook
For k = 1 To .Worksheets.Count
Set wS1 = .Worksheets(k)
lastRow1 = wS1.Cells(Rows.Count, "A").End(xlUp).Row
'▼「IDデータBook」の各SheetのF列を作業用の列として使用
If lastRow1 > 1 Then
Range(wS1.Cells(2, "F"), wS1.Cells(lastRow1, "F")).Formula = "=A2&""_""&B2" '★作業列をF列に変更
'▼「ID管理票Book、シート1」の作業列（F列）でフィルタを掛ける
'表示されている行のC列に「IDデータBook」の○番目シートのC列データを、E列にはシート名を！
For i = 2 To lastRow1 '★
wS2.Rows(5).AutoFilter field:=6, Criteria1:=wS1.Cells(i, "F") '★5行目が項目行なので5行目でフィルタを掛ける
If wS2.Cells(Rows.Count, "A").End(xlUp).Row > 5 Then '★表示されている最終行が6行目以降にあれば
Range(wS2.Cells(6, "C"), wS2.Cells(lastRow2, "C")).SpecialCells(xlCellTypeVisible) = wS1.Cells(i, "C") '★
Range(wS2.Cells(6, "E"), wS2.Cells(lastRow2, "E")).SpecialCells(xlCellTypeVisible) = wS1.Name '★
End If
Next i
'▼「IDデータBook、各Sheet」の作業列を消去
wS1.Range("F:F").ClearContents
End If
Next k
End With
'▼オートフィルタを解除、「ID管理票、シート1の作業列（F列）を消去
wS2.AutoFilterMode = False
wS2.Range("F:F").ClearContents
Application.ScreenUpdating = True
End Sub

こんな感じではどうでしょうか？m(_ _)m

お礼

tom04様

今回もご対応頂き誠にありがとうございます。
非常に恥ずかしい話でありますが、
回答を拝見させてようやくわかりました。
lastlow2の部分は変数宣言してたですね
この部分を普通の行の最終項目だと思っていました。
お恥ずかしい限りです。

再三の質問で丁寧な対応と
分かりやすいコメント含めて参考になると同時に
自分の力不足を実感するばかりです。

修正して頂いたコードで問題ありません！

実データするのが少し時間かかるので
確認後、ベストアンサーに選ばせて頂きます。

前回の対応に引き続き
今回のご対応ありがとうございます！！

補足

返答、遅くなり申し訳ありません
無事、実際のデータで動きました。
2度の質問の丁寧な対応に感謝致します。

ほんとうにありがとうございます