エクセル 2つの表比較

※上sheet2
　中sheet1
　下sheet3
　データは各シートB4から入っています。　

sheet3の品番判定のマクロを組みたいのですがうまくいきません。
条件は、sh2にG～(同じコード)があるか。部品は同じか。⇒ コードがあり部品が同じならば”T”
コードはあるが、部品が違う。⇒ ”変更”
sh2にコードが無い。⇒ ”追加”
といった感じで表示させたいです。
例↓
G502＿＿＿GG0002 ⇒ G501＿＿＿GG0003 = 追加
G503＿＿＿GG0003 ⇒ G502＿＿＿GG0003 = 変更
G504＿＿＿GG0001 ⇒ G503＿＿＿GG0003 = T

私が組んだのだと途方も無く時間がかかり、しかも全部追加になってしまい悩んでます。
ご教授お願いいたします。
Sub change()

Dim CNT1, CNT2, CNT3, CNT4
Set sh3 = Sheet3
Set sh2 = Sheet2
Set sh1 = Sheet1

For CNT2 = 2 To 5
For CNT1 = 4 To 200
For CNT4 = 2 To 5
For CNT3 = 4 To 200
If sh2.Cells(CNT1, CNT2).Value <> "" Then
If sh2.Cells(CNT1, CNT2).Value <> sh1.Cells(CNT3, CNT4).Value Then
sh3.Cells(CNT1, CNT2 + 9).Value = "追加"
Else
If sh2.Cells(CNT1, 6).Value = sh1.Cells(CNT3, 6).Value Then
sh3.Cells(CNT1, CNT2 + 9).Value = "T"
Else
sh3.Cells(CNT1, CNT2 + 9).Value = "変更"
End If
End If
Else
sh3.Cells(CNT1, CNT2 + 9).Value = ""
End If
Next CNT3
Next CNT4
Next CNT1
Next CNT2
End Sub

質問者からの補足コメント

• ＞Sheet2のG502はA2ですか？
  sheet1,2,3すべてB4です。
  ＞sheet3のA2のG502は、sheet2のどの列を検索ですか？
  括弧ないのとおりです。BCDにもデータが入ることがあります。(データ区切りを使用しているため)
  ＞部品は同じかという意味は、品番の比較ですか？
  品番が同じかという意味です。
  ＞sheet3のB2は、sheet2のB2～Bの最後まで検索で良いですか？
  200までの検索です。
  ＞結果を書き込む欄は、sheet3の判定欄で良いですか。
  sheet3でお願いします。
  ＞sheet1は、検索しなくてよいですか。
  sheet1とsheet2を比較しています。
  sheet3にはsheet2の写し(G502等)が入っているので結果だけsheet3に表示させています。
  お手数かけますがお願いします。

  No.1の回答に寄せられた補足コメントです。 補足日時：2017/01/06 08:10

• ひとつ忘れていました。
  １）①、②、③おっしゃる通りです。
  ただ、G～(以下コードします)と紐付けて品番の一致、不一致の判定にしたいと思ってます。
  以前はカウントイフで表にあるかだけ判定していて変更もれをおこしたことがあり、その対処のために今回質問させていただいてます。
  ２）追加に関してはG列からJ列でコードが一致するかの判定を出していますので、品番判定はK列からM列に結果を表示させたいです。
  
  度々申し訳ございません。よろしくお願いしたします。

  No.2の回答に寄せられた補足コメントです。 補足日時：2017/01/06 10:16

• 

  連想配列...はじめてききました。
  
  動かしてみて一つ思ったことがありまして、質問の追加をさせてほしいです。
  
  O列からR列まで変更もとの品番を表示させようとしているのですが、そちらのほうも出来れば手を加えていただきたいです...
  
  私は関数を入れてたんですが案の定ずれて表示されているので...
  =IF($K$4="変更",元部品表!$F$4,"")
  お時間よろしければご教授お願いします。

  No.3の回答に寄せられた補足コメントです。 補足日時：2017/01/06 11:07

No.5 ベストアンサー 回答者： tatsu99 回答日時： 2017/01/06 11:45

以下のようになります。

前のは破棄してください。
---------------
Option Explicit

Public Sub 品番判定()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim dicT As Object '連想配列（キー：品名）（値：品番）
Dim row As Long
Dim col As Long
Dim key As String
Dim hantei As String '判定
Dim hinban As String '変更前品番
Set sh1 = Worksheets("sheet1")
Set sh2 = Worksheets("sheet2")
Set sh3 = Worksheets("sheet3")
Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義
'sheet1の品名のリストを作成する
For row = 4 To 200
For col = 2 To 5
'品名が空白でないなら、品番を記憶する
key = sh1.Cells(row, col).Value
If key <> "" Then
dicT(key) = sh1.Cells(row, 6).Value
End If
Next
Next
'sheet2の品名がsheet1にあるか検索する
For row = 4 To 200
For col = 2 To 5
hinban = "" '変更前品番クリア
'品名が空白でないなら、Sheet1にあるか判定する
key = sh2.Cells(row, col).Value
If key <> "" Then
'Sheet1にあれば、品番は一致か判定する
If dicT.exists(key) = True Then
If sh2.Cells(row, 6).Value = dicT(key) Then
hantei = "T"
Else
hantei = "変更"
hinban = dicT(key)
End If
Else
hantei = "追加"
End If
Else
hantei = "" '品名が空白なら判定は空白
End If
'判定結果をセット
sh3.Cells(row, col + 9).Value = hantei
'変更前品番をセット
sh3.Cells(row, col + 13).Value = hinban
Next
Next
MsgBox ("処理完了")
End Sub
--------------------

この回答へのお礼

ここまでお手数おかけして申し訳ございませんでした。
おかげさまでちゃんと動いてくれました。
ありがとうございました。

お礼日時：2017/01/06 11:58

No.4 回答者： tatsu99 回答日時： 2017/01/06 11:17

>O列からR列まで変更もとの品番を表示させようとしているのですが、そちらのほうも出来れば手を加えていただきたいです...

判定結果が、”変更”の場合、O列～R列へ変更前の品番（Sheet1の品番）を設定し、
”変更”以外は、O列～R列へ空白を設定する。

ということでよいですか。

この回答へのお礼

おっしゃる通りでございます。

もうほんと頭が上がりません。ありがとうございます。

お礼日時：2017/01/06 11:19

No.3 回答者： tatsu99 回答日時： 2017/01/06 10:45

以下のようになります。

--------------------------------------
Public Sub 品番判定()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim dicT As Object '連想配列（キー：品名）（値：品番）
Dim row As Long
Dim col As Long
Dim key As String
Dim hantei As String
Set sh1 = Worksheets("sheet1")
Set sh2 = Worksheets("sheet2")
Set sh3 = Worksheets("sheet3")
Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義
'sheet1の品名のリストを作成する
For row = 4 To 200
For col = 2 To 5
'品名が空白でないなら、品番を記憶する
key = sh1.Cells(row, col).Value
If key <> "" Then
dicT(key) = sh1.Cells(row, 6).Value
End If
Next
Next
'sheet2の品名がsheet1にあるか検索する
For row = 4 To 200
For col = 2 To 5
'品名が空白でないなら、Sheet1にあるか判定する
key = sh2.Cells(row, col).Value
If key <> "" Then
'Sheet1にあれば、品番は一致か判定する
If dicT.exists(key) = True Then
If sh2.Cells(row, 6).Value = dicT(key) Then
hantei = "T"
Else
hantei = "変更"
End If
Else
hantei = "追加"
End If
Else
hantei = "" '品名が空白なら判定は空白
End If
'判定結果をセット
sh3.Cells(row, col + 9).Value = hantei
Next
Next
MsgBox ("処理完了")
End Sub
-----------------------------------------------------
スピードアップの為、連想配列を使用しています。
不明点があれば補足してください。

No.2 回答者： tatsu99 回答日時： 2017/01/06 09:57

補足ありがとうございました。

以下の理解で良いでしょうか。
１）sheet2の品名がSheet1にあるかチェックする。
①sheet1になければ、”追加”とする。
②sheet1にあり、品番が一致すれば、”T"とする。
③sheet1にあり、品番が一致しなければ、”変更"とする。

２）上記の判定結果は、sheet3の品番判定の欄（K列～M列）に書き込む。
（判定欄（G列～J列）には書き込まない）

上記で間違いないでしょうか。

No.1 回答者： tatsu99 回答日時： 2017/01/05 18:19

すみません。

状況がよくわかりません。
まず、セルの位置ですが
Sheet2のG502はA2ですか？（上のシート）（とりあえずA2として以降の質問をします）
Sheet1のG501はA2ですか？（中のシート）（とりあえずA2として以降の質問をします）
Sheet3のG502はA2ですか？（中のシート）（とりあえずA2として以降の質問をします）

sheet3のA2のG502は、sheet2のどの列を検索ですか。
（sheet2のA２～Aの最後の行ですか、それともB、C、D列が空白でないなら、B,C,D列も検索するのですか）
部品は同じかという意味は、品番の比較ですか？
（sheet3のE2のGG0001とsheet2のE2のG0001は一致なのでT）

sheet3のB2は、sheet2のB2～Bの最後まで検索で良いですか？
結果を書き込む欄は、sheet3の判定欄で良いですか。（品番判定の欄には書き込まない）

sheet1は、検索しなくてよいですか。（sheet1を検索する旨がどこにも記述されていない）