Excel VBA質問箱 IV

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

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


6584 / 13644 ツリー ←次へ | 前へ→

【44413】シートの比較、ご教授下さい。(再再記載) ドルフィン 06/11/15(水) 18:46 質問[未読]
【44416】Re:シートの比較、ご教授下さい。(再再記... ichinose 06/11/15(水) 19:55 発言[未読]
【44417】Re:シートの比較、ご教授下さい。(再再記... ドルフィン 06/11/15(水) 20:10 お礼[未読]

【44413】シートの比較、ご教授下さい。(再再記載...
質問  ドルフィン  - 06/11/15(水) 18:46 -

引用なし
パスワード
   シート比較、ご教授下さいm( _ _ )m
どなたかご教示下さい。

以下のようなSheet1とSheet2があります。
この2つのシートを比較して、Sheet3に比較結果を書き出します。

・現在、プログラムを実行すると【◆(求めている結果)】ではなく
 【◆(現状出てしまう結果)】のアンマッチ結果が出てしまいます。

・(とらん)及び(ますた)のコード1とコード2が文字列である為、
 アンマッチと出ていると思われます。
 
・(とらん)及び(ますた)のコード1とコード2の値を数値にすると
 求めている結果となりました。

vba初心者なもので、どなたかご教授頂けますでしょうか。

―――――――――――――――――――――――――――
◆(とらん)
  A    B    C  D  E  F  G  H  I  J  K
1|コード1 コード2 記号 項1 項2 項3 項4 項5 項6 項7 項8
2|A001  101   A  1  1  1  1  1  1  1  1
3|B001  202   U  2  2  2  2  2  2  2  2
4|C001  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|A001  101     1  1  1  1  1  1  1  1
3|A001  101     1  1  1  1  1  1  1  1
3|B001  202     2  2  2  2  2  2  2  2
4|C001  303     3  3  3  3  3  3  3  3

◆(求めている結果)
1|Sheet  コード1 コード2 記号 項1 項2 項3 項4 項5 項6 項7 項8
2|1    A001  101   A  1  1  1  1  1  1  1  1
3|2    A001  101      1  1  1  1  1  1  1  1
4|1    B001  202   U  2  2  2  2  2  2  2  2
5|2    B001  202      2  2  2  2  2  2  2  2
6|1    C001  303   U  3  3  3  3  3  3  3  3
7|2    C001  303      3  3  3  3  3  3  3  3

-----------------------------------------------------------------------
◆(現状出てしまう結果)
1|Sheet  コード1 コード2 記号 項1 項2 項3 項4 項5 項6 項7 項8
2|1    A001  101   A  1  1  1  1  1  1  1  1
3|2    *    *
4|1    B001  202   U  2  2  2  2  2  2  2  2
5|2    *    *
6|1    C001  303   U  3  3  3  3  3  3  3  3
7|2    *    *

―仕様――――――――――――――――――――――――――
1)「とらん」を1件づつ読込み、コード1とコード2をキーに「ますた」を検索し、

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

  ◆存在した場合、項目1〜8を比較し、「とらん」と「ますた」の情報を
   [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, jdx 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
        .Range(.Cells(idx * 2 + 1, 2), .Cells(idx * 2 + 1, 12)).Value = sh2rng(rw).Resize(, 11).Value
        Select Case sh1rng(idx, 3).Value
          Case "A", "U":
            For jdx = 5 To 12
             If .Cells(idx * 2, jdx).Value <> .Cells(idx * 2 + 1, jdx).Value Then
               .Cells(idx * 2 + 1, jdx).Interior.ColorIndex = 3
               End If
             Next jdx
         Case Else:
          .Range(.Cells(idx * 2 + 1, 2), .Cells(idx * 2 + 1, 3)).Interior.ColorIndex = 3
        End Select
       End If
       End With
     Next
    End If
End Sub
-------------------------------
以上です。
それでは失礼致します。

【44416】Re:シートの比較、ご教授下さい。(再再...
発言  ichinose  - 06/11/15(水) 19:55 -

引用なし
パスワード
   こんばんは。

文字列だとそうなりますね!!
これは、明らかにバグです。


>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, jdx 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).Address(, , , True) & _
           ")*(" & addB & "=" & _
           sh1rng.Offset(0, 1).Cells(idx).Address(, , , True) & _
           "),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
>        .Range(.Cells(idx * 2 + 1, 2), .Cells(idx * 2 + 1, 12)).Value = sh2rng(rw).Resize(, 11).Value
>        Select Case sh1rng(idx, 3).Value
>          Case "A", "U":
>            For jdx = 5 To 12
>             If .Cells(idx * 2, jdx).Value <> .Cells(idx * 2 + 1, jdx).Value Then
>               .Cells(idx * 2 + 1, jdx).Interior.ColorIndex = 3
>               End If
>             Next jdx
>         Case Else:
>          .Range(.Cells(idx * 2 + 1, 2), .Cells(idx * 2 + 1, 3)).Interior.ColorIndex = 3
>        End Select
>       End If
>       End With
>     Next
>    End If
>End Sub
>-------------------------------
>以上です。
>それでは失礼致します。

【44417】Re:シートの比較、ご教授下さい。(再再...
お礼  ドルフィン  - 06/11/15(水) 20:10 -

引用なし
パスワード
   ▼ichinose さん:

ichinose様

早速のご返答ありがとうございます。

色々と項目を変更してみたり試してみたのですが
私の知識では、とほほでしてご質問に至りました。

ご指摘の箇所を修正して試してみます。
誠にありがとうございます。

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