シートAとシートBの得意先コードが一致したら、該当行をシートCにコピー

質問

シートAとシートBの得意先コードが一致したら、該当行をシートCにコピーするVBAを組みたいのですが、上手く行きません。加えてシートＡの該当行は削除しておきたいです。
ＸＰで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列= 得意先ＣＤを取得
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列 = 得意先ＣＤを取得
intCnt = 2 '2行から
If strSrhCode = strSrhCode2 Then 'もし検索値と検索対象シートの得意先ＣＤが一致したら
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

言葉足らずの所があればごめんなさい。
追記いたしますので、教えて下さい。
よろしくお願い致します。

回答No.3

mimeu · ベストアンサー

同じ事をしているだけですが、こういうプログラム表記も
読みやすいかと思いますので、ご参考になさって下さい。

Option Explicit

' 話の前提として、シートA, シートB はそれぞれ列Aで昇順に並べ替えてあるものとします
Sub 転記と削除()
　　Dim 行A As Long, 行B As Long, 行C As Long
　　Dim 最下行A As Long, 最下行B As Long
　　Dim シートA As Worksheet, シートB As Worksheet, シートC As Worksheet
　　' 以下３行のシート名は適宜修正して下さいネ
　　Set シートA = Worksheets("A")
　　Set シートB = Worksheets("B")
　　Set シートC = Worksheets("C")
　　' 以下３行はこのように仮定していますが、違ってたら修正して下さいネ
　　Const 開始行A = 2
　　Const 開始行B = 2
　　Const 開始行C = 2
　　' 以下２行もこのように仮定していますが、違ってたら修正して下さいネ
　　最下行A = シートA.Range("A1").End(xlDown).Row
　　最下行B = シートB.Range("A1").End(xlDown).Row

　　行A = 最下行A
　　行B = 最下行B
　　行C = 開始行C
　　Do
　　　　If シートA.Cells(行A, 1) > シートB.Cells(行B, 1) Then
　　　　　　行A = 行A - 1
　　　　　　If 行A < 開始行A Then Exit Do
　　　　ElseIf シートA.Cells(行A, 1) < シートB.Cells(行B, 1) Then
　　　　　　行B = 行B - 1
　　　　　　If 行B < 開始行B Then Exit Do
　　　　Else
　　　　　　シートA.Range("A" & 行A & ":K" & 行A).Copy シートC.Range("A" & 行C)
　　　　　　シートA.Range("A" & 行A).EntireRow.Delete
　　　　　　行A = 行A - 1
　　　　　　If 行A < 開始行A Then Exit Do
　　　　　　行B = 行B - 1
　　　　　　行C = 行C + 1
　　　　End If
　　Loop
　　' シートC も列Aで昇順に並べ替える
　　If 行C > 2 Then
　　　　シートC.Range("A1:K" & (行C - 1)).Sort Key1:=シートC.Range("A2") _
　　　　　　, Order1:=xlAscending, Header:=xlGuess
　　End If
End Sub

お礼

ご回答いただきありがとうございました。

mimeu様が書いて下さったのも実行してみたのですが、
シートＣに１行もコピーされないのです．．．．。
全くないというのはないので、やはり何か私の方で最初からミスっているのだと思います。
実際、最初に投稿した内容で変数の書き間違いを発見してしまってます。
申し訳ありません。
そこのところ修正して、mimeu様が書いて下さったのも見直してもう一度やり直して、シートＣにコピーされないので、この投稿は一旦終了とした方が良いと思っています。

返信頂いたのにすみません。
でも、教えて頂いたマクロは保存して、時間かけてやってみます。

回答No.2

hana-hana3

＞シートＣにコピーされなかったです．．．。

大きな改変はしていませんが・・・。
プロシージャー外のコードを追加して試して頂いているものと思っていますが、これは記述してありますよね？
そうでないとエラーになりますから。
-----------------------------------
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の最終行
-------------------------------------------

あとは、コピー処理の部分を
-------------------------------------------
For y = 1 To 11
With Sheets(strSrhSheet)
.Cells(intCnt, y) = Sheets(strMasSheet2).Cells(intRow, y)
End With
Next
--------------------------------------------
のように修正してみてください。

お礼

ご回答いただきありがとうございました。

修正して下さったのも実行してみたのですが、シートＣに１行もコピーされないのです．．．．。
（前のも変数の宣言等々は抜けていません）
全くないというのはないので、やはり何か私の方で最初からミスっているのだと思います。
実際、最初に投稿した内容で変数の書き間違いを発見してしまってます。
申し訳ありません。
イミディエイトで変数の動きを見てみたりもしてみたのですが．．．．。
回答頂いたのに本当すみません。
でも、教えて頂いたマクロは保存して、時間かけてやってみます。

回答No.1

hana-hana3

＞上手く行きません。加えてシートＡの該当行は削除しておきたいです。

何がうまく行かないのか解りませんが・・・。
行削除を伴う場合、データを上から検索して削除すると自分の位置（現在行）の認識に矛盾が生じる事になるので、それを理解している方は最下行からの検索と削除を行うプログラムを書きます。

テストはしていませんからイメージとして・・・。

Sub データを分ける2()

Dim y As Integer
Dim flg As Boolean

maxgyo = Sheets(strMasSheet).Cells(Rows.Count, 1).End(xlUp).Row 'シートAの最終行を取得
maxgyo2 = Sheets(strMasSheet2).Cells(Rows.Count, 1).End(xlUp).Row 'シートBの最終行を取得

For intRow = maxgyo To 2 '最終行から始めて2まで（1downで）

strSrhCode = Sheets(strMasSheet).Cells(intRow, 2) '検索値 B列= 得意先ＣＤを取得
flg = False 'フラグリセット

For intRow2 = 2 To maxgyo '2行から始めて最終行まで（1upで）

strSrhCode2 = Sheets(strMasSheet).Cells(intRow, 8) '検索値 H列 = 得意先ＣＤを取得
intCnt = 2 '2行から

If strSrhCode = strSrhCode2 Then 'もし検索値と検索対象シートの得意先ＣＤが一致したら

intCnt = intCnt + 1
flg = True 'フラグセット

For y = 1 To 11
With Sheets(strSrhSheet)
.Cells(intCnt, y) = Cells(intRow, y)
End With
Next

End If
Next intRow2

If flg Then 'データが見つかった場合、行削除
Sheets(strMasSheet).Rows(intRow).Delete
End If

Next intRow

MsgBox "処理終了"
End Sub

お礼

ご回答いただきありがとうございました。

>行削除を伴う場合、最下行からの検索と削除を行う
全く理解しておらず、勉強になりました。

書いて下さったのを試してみたのですが、シートＣにコピーされなかったです．．．。
私が何か重要なことを分かっていない、ここに書ききれてないせいかもしれませんね。
もう少し試行錯誤してみます。