行列で検索をかけてその結果を転記するＶＢＡは

質問

早速ですが質問させていただきます。
sheet1のＡ列に月日、２行目に製品名をとり製品個数を記した表があります。（列数150行数1000です）これをsheet3のCells(2, 6)に記入した月日とCells(2, 4)に記入した製品名（文字）の２つでsheet1の行と列から当てはまるセルの検索をコマンドボタンを押すことにより行い、そのセルにsheet3のCells(2, 7)に記入した製品個数を転記するようなＶＢＡを書きました。
Private Sub CommandButton1_Click()
Dim LastA, idxA As Long, trgA, trgB
With Worksheets("Sheet3")
LastA = .Range("A1000").End(xlUp).Row
trgA = Application.Match(.Cells(2, 6), Worksheets("Sheet1").Range("A:A"), 0)
For idxA = LastA To 3 Step -1
trgB = Application.Match(.Cells(2, 4), Worksheets("Sheet1").Range("2:2"), 0)

Worksheets("Sheet1").Cells(trgA, trgB) = .Cells(2, 7)
Next idxA
End With
End Sub

以前質問して教えていただいたものを参考に、少し変更してみたのですがこれで正しいでしょうか？実行するとうまく転記するのですがかなり時間がかかってしまい、もう少し何とかならないものかと思っています。どなたかご指導お願いします。

回答No.2

Wendy02 · ベストアンサー

こんばんは。

元のコードは、まったく無意味な部分があるような気がしますね。
以下のようなコードはいかがでしょうか？
このコードは、古いスタイル雰囲気があります。
かならず、エラー処理はつけたほうがよいです。

.Cells(2, 6).Value2　としてありますので、書式に違いには影響を受けません。

Private Sub CommandButton1_Click()
　Dim trgA As Variant, trgB As Variant

　With Worksheets("Sheet3")
　　If IsEmpty(.Cells(2, 7)) Then MsgBox "個数が空です。", vbCritical: Exit Sub
　　'日付
　　trgA = Application.Match(.Cells(2, 6).Value2, Worksheets("Sheet1").Range("A:A"), 0)
　　　If IsError(trgA) Then MsgBox "該当する日付がありません。", vbCritical: Exit Sub

　　 '製品名　
　　trgB = Application.Match(.Cells(2, 4).Value, Worksheets("Sheet1").Range("2:2"), 0)
　　If IsError(trgB) Then MsgBox "該当する製品名がありません。", vbCritical: Exit Sub

　　If Worksheets("Sheet1").Cells(trgA, trgB).Value = "" Then
　　　　Worksheets("Sheet1").Cells(trgA, trgB).Value = .Cells(2, 7).Value
　　Else
　　　If MsgBox("上書きしますか", vbQuestion + vbOKCancel) = vbOK Then
　　　Worksheets("Sheet1").Cells(trgA, trgB).Value = .Cells(2, 7).Value
　　　End If
　　End If
　End With
End Sub

お礼

早速、回答いただき有難うございました。

↓にも書きましたが必要ない部分がありました。消すことによってうまくいきましたが、Wendy02さんのコードを採用させていただきます。エラー処理は全然頭になかったので・・・。新しく作っていただき感謝しております。

みなさん本当に有難うございました。

回答No.1

papayuka

LastA と idxA のループは使われてないような、、、
あまり変わらないような気もしますが、※の１～３を消すと早くなりますか？
あと、対象シートは計算式がいっぱいのシートですか？

With Worksheets("Sheet3")
　LastA = .Range("A1000").End(xlUp).Row　'※１
　trgA = Application.Match(.Cells(2, 6), Worksheets("Sheet1").Range("A:A"), 0)
　For idxA = LastA To 3 Step -1　　　　　'※２
　　　trgB = Application.Match(.Cells(2, 4), Worksheets("Sheet1").Range("2:2"), 0)
　　　Worksheets("Sheet1").Cells(trgA, trgB) = .Cells(2, 7)
　Next idxA　　　　　　　　　　　　　　　'※３
End With

お礼

早速、回答いただき有難うございました。

仰るとおり※は必要なかったです。消去しましたら早くなりました。
依然教えていただいた時の解釈が間違っていました。Cells(2, 6)の値とMatchするものをRange("A1000")からひとつずつ上にチェックするんだなと思っておりました。ぜんぜん必要なかったなんて・・ばかですねー。
助かりました、本当に有難うございました。