Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


37614 / 76732 ←次へ | 前へ→

【44281】シートの比較、ご教授下さい。(再記載)
お礼  ドルフィン  - 06/11/12(日) 0:24 -

引用なし
パスワード
   シート比較、ご教授下さいm( _ _ )m
どなたかご教示下さい。vba初心者です。
以下のようなSheet1とSheet2があります。

この2つのシートを比較して、Sheet3に比較結果を書き出します。
ですが、以下に記載したプログラムを実行すると、結果[Sheet3]の
5、7行目の項目1〜8のセルの背景色が赤く表示されてしまいます。
結果の値の出力は仕様通り表示されています。
―――――――――――――――――――――――――――
◆(とらん)
  A    B    C  D  E  F  G  H  I  J  K
1|コード1 コード2 記号 項1 項2 項3 項4 項5 項6 項7 項8
2|1001  101   A  1  1  1  1  1  1  1  1
3|2001  202   U  2  2  2  2  2  2  2  2
4|3001  303   U  3  3  3  3  3  3  3  3

◆(ますた)
  A    B    C  D  E  F  G  H  I  J  K
1|コード1 コード2 記号 項1 項2 項3 項4 項5 項6 項7 項8
2|1001  101     1  1  1  1  1  1  1  1
3|1001  101     1  1  1  1  1  1  1  1
3|2001  202     2  2  2  2  2  2  2  2
4|3001  303     3  3  3  3  3  3  3  3

◆(結果)
1|Sheet  コード1 コード2 記号 項1 項2 項3 項4 項5 項6 項7 項8
2|1    1001  101   A  1  1  1  1  1  1  1  1
3|2    1001  101      1  1  1  1  1  1  1  1
4|1    2001  202   U  2  2  2  2  2  2  2  2
5|2    2001  202      2  2  2  2  2  2  2  2
6|1    3001  303   U  3  3  3  3  3  3  3  3
7|2    3001  303      3  3  3  3  3  3  3  3
―仕様――――――――――――――――――――――――――
1)「とらん」を1件づつ読込み、コード1とコード2をキーに「ますた」を検索し、

  『とらん』「記号」="A"の場合

  ◆存在した場合、項目1,2,3を比較し、「とらん」と「ますた」の情報を
   [Sheet3]に結果を書き出します。
   「ますた」に複数存在した場合は1件目のレコードで比較します。
   アンマッチ項目があった場合、その項目のセルを赤く表示します。

  ◆存在しなかった場合、「とらん」のレコードはそのまま[Sheet3]に
   結果を書き出し、マスタのキーエリアに"*"を設定し、セルを赤く。

  『とらん』「記号」="D"の場合

  ◆存在しなかった場合、「とらん」のレコードはそのまま[Sheet3]に
   結果を書き出し、「ますた」はキーエリアに"-"を設定します。

  ◆存在した場合、[Sheet3]に結果を書き出します。
   「ますた」に複数存在した場合は1件目のレコードで比較します。
   アンマッチ項目があった場合、その項目のセルを赤く表示します。

  以上を「とらん」のレコードがなくなるまで繰り返します。
 ※「とらん」は十件程度です。「とらん」がゼロ件の場合は処理を行いません

----
どなたか解る方がいらっしゃいましたら、ご教授の程、宜しくお願い致します。
  
―プログラム――――――――――――――――――――――――――
Sub 実行()
  Dim sh1rng As Range
  Dim sh2rng As Range
  Dim addA As String
  Dim addB As String
  Dim sh2strw As Long
  Dim idx As Long
  Dim rw As Variant
  Dim nsign As String
  '↓本文
  With Worksheets("sheet1")
    Set sh1rng = .Range("a2", .Cells(.Rows.Count, "a").End(xlUp))
    End With
  If sh1rng.Row > 1 Then
    With Worksheets("sheet2")
     Set sh2rng = .Range("a2", .Cells(.Rows.Count, "a").End(xlUp))
     sh2strw = sh2rng.Row
     If sh2strw > 1 Then
       addA = sh2rng.Address(, , , True)
       addB = sh2rng.Offset(0, 1).Address(, , , True)
       End If
     End With
    For idx = 1 To sh1rng.Count
     rw = CVErr(xlErrNA)
     If sh2strw > 1 Then
       rw = Evaluate("=match(1,(" & addA & "=" & sh1rng.Cells(idx) & _
             ")*(" & addB & "=" & sh1rng.Offset(0, 1).Cells(idx) & _
             "),0)")
       '↑検索
       End If
     With Worksheets("sheet3")
       .Cells(idx * 2, 1).Value = 1
       .Range(.Cells(idx * 2, 2), .Cells(idx * 2, 12)).Value = sh1rng(idx).Resize(, 11).Value
       .Cells(idx * 2 + 1, 1).Value = 2
       If IsError(rw) Then
        Select Case sh1rng(idx, 3).Value
         Case "D":
            nsign = "-"
         Case Else:
            nsign = "*"
            .Range(.Cells(idx * 2 + 1, 2), .Cells(idx * 2 + 1, 3)).Interior.ColorIndex = 3
        End Select
        .Range(.Cells(idx * 2 + 1, 2), .Cells(idx * 2 + 1, 3)).Value = nsign
       Else
        Select Case sh1rng(idx, 3).Value
          Case "A", "U":
            If sh1rng(idx, 4).Value <> sh2rng(idx, 4).Value Then
             .Range(.Cells(idx * 2 + 1, 5), .Cells(idx * 2 + 1, 5)).Interior.ColorIndex = 3
            End If
            If sh1rng(idx, 5).Value <> sh2rng(idx, 5).Value Then
             .Range(.Cells(idx * 2 + 1, 6), .Cells(idx * 2 + 1, 6)).Interior.ColorIndex = 3
            End If
            If sh1rng(idx, 6).Value <> sh2rng(idx, 6).Value Then
             .Range(.Cells(idx * 2 + 1, 7), .Cells(idx * 2 + 1, 7)).Interior.ColorIndex = 3
            End If
            If sh1rng(idx, 7).Value <> sh2rng(idx, 7).Value Then
             .Range(.Cells(idx * 2 + 1, 8), .Cells(idx * 2 + 1, 8)).Interior.ColorIndex = 3
            End If
            If sh1rng(idx, 8).Value <> sh2rng(idx, 8).Value Then
             .Range(.Cells(idx * 2 + 1, 9), .Cells(idx * 2 + 1, 9)).Interior.ColorIndex = 3
            End If
            If sh1rng(idx, 9).Value <> sh2rng(idx, 9).Value Then
             .Range(.Cells(idx * 2 + 1, 10), .Cells(idx * 2 + 1, 10)).Interior.ColorIndex = 3
            End If
            If sh1rng(idx, 10).Value <> sh2rng(idx, 10).Value Then
             .Range(.Cells(idx * 2 + 1, 11), .Cells(idx * 2 + 1, 11)).Interior.ColorIndex = 3
            End If
            If sh1rng(idx, 11).Value <> sh2rng(idx, 11).Value Then
             .Range(.Cells(idx * 2 + 1, 12), .Cells(idx * 2 + 1, 12)).Interior.ColorIndex = 3
            End If
            .Range(.Cells(idx * 2 + 1, 2), .Cells(idx * 2 + 1, 12)).Value = sh2rng(rw).Resize(, 11).Value
         Case Else:
          .Range(.Cells(idx * 2 + 1, 2), .Cells(idx * 2 + 1, 3)).Interior.ColorIndex = 3
          .Range(.Cells(idx * 2 + 1, 2), .Cells(idx * 2 + 1, 12)).Value = sh2rng(rw).Resize(, 11).Value
        End Select
       End If
       End With
     Next
    End If
End Sub

-----
以上です。
それでは失礼致します。

0 hits

【44281】シートの比較、ご教授下さい。(再記載) ドルフィン 06/11/12(日) 0:24 お礼
【44283】Re:シートの比較、ご教授下さい。(再記載) ドルフィン 06/11/12(日) 0:33 発言
【44288】Re:シートの比較、ご教授下さい。(再記載) ichinose 06/11/12(日) 8:21 発言
【44296】Re:シートの比較、ご教授下さい。(再記載) ドルフィン 06/11/12(日) 12:08 お礼
【44287】Re:シートの比較、ご教授下さい。(再記載) Hirofumi 06/11/12(日) 3:07 回答
【44295】Re:シートの比較、ご教授下さい。(再記載) ドルフィン 06/11/12(日) 11:52 お礼

37614 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free