シートAとシートBの得意先コードが一致したら、該当行をシートCにコピー
シートAとシートBの得意先コードが一致したら、該当行をシートCにコピーするVBAを組みたいのですが、上手く行きません。加えてシートAの該当行は削除しておきたいです。
XPでExcel2003を使用しています。
Const strMasSheet = "A"
Const strMasSheet2 = "B"
Const strSrhSheet = "C"
Dim strSrhCode As Long 'シートAの得意先コード
Dim strSrhCode2 As Long 'シートBの得意先コード
Dim intRow As Long
Dim intRow2 As Long
Dim intCnt As Long
Dim maxgyo As Long 'シートAの最終行
Dim maxgyo2 As Long 'シートBの最終行
Sub データを分ける()
maxgyo = Sheets(strMasSheet).Cells(Rows.Count, 1).End(xlUp).Row 'シートAの最終行を取得
For intRow = 2 To maxgyo '2行から始めて最終行まで(1upで)
strSrhCode = Sheets(strMasSheet).Cells(intRow, 2) '検索値 B列= 得意先CDを取得
maxgyo2 = Sheets(strMasSheet2).Cells(Rows.Count, 1).End(xlUp).Row 'シートBの最終行を取得
For intRow2 = 2 To maxgyo '2行から始めて最終行まで(1upで)
strSrhCode2 = Sheets(strMasSheet).Cells(intRow, 8) '検索値 H列 = 得意先CDを取得
intCnt = 2 '2行から
If strSrhCode = strSrhCode2 Then 'もし検索値と検索対象シートの得意先CDが一致したら
intCnt = intCnt + 1
With Sheets(strSrhSheet)
.Cells(intCnt, 1) = Cells(intRow, 1)
.Cells(intCnt, 2) = Cells(intRow, 2)
.Cells(intCnt, 3) = Cells(intRow, 3)
.Cells(intCnt, 4) = Cells(intRow, 4)
.Cells(intCnt, 5) = Cells(intRow, 5)
.Cells(intCnt, 6) = Cells(intRow, 6)
.Cells(intCnt, 7) = Cells(intRow, 7)
.Cells(intCnt, 8) = Cells(intRow, 8)
.Cells(intCnt, 9) = Cells(intRow, 9)
.Cells(intCnt, 10) = Cells(intRow, 10)
.Cells(intCnt, 11) = Cells(intRow, 11)
End With
End If
Next intRow2
Next intRow
MsgBox "処理終了"
End Sub
言葉足らずの所があればごめんなさい。
追記いたしますので、教えて下さい。
よろしくお願い致します。
お礼
ご回答ありがとうございます。 該当のページは既に見させていただいてました。 記事中のRefresh()を試してみたのですが、いまいちどこに入れていいか分からず、入れて実行してもRefresh()でエラーが発生してしまいました。 何か解決策はありますでしょうか?