Excel VBA質問箱 IV

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

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


37701 / 76732 ←次へ | 前へ→

【44193】Re:シート比較、ご教授下さいm( _ _ )m
発言  ichinose  - 06/11/8(水) 7:35 -

引用なし
パスワード
   ▼ドルフィン さん:
おはようございます。
仕様書としては、わかりやすい記述ですね!!
次回からは、これにご自分が考えたコードも記述してください
そうするともっと勉強にはなると思いますよ!!

>どなたかご教示下さい。
>以下のようなSheet1とSheet2があります。
>この2つのシートを比較して、Sheet3に比較結果を
>書き出す方法をご教示下さい。
>
>[Sheet1] ( とらん )
>  A   B   C   D    E    F
>1 |コード1 コード2 記号  項目1  項目2  項目3
>2 |1001  101  A   K11   K21   K31
>3 |2001  202  A   K12   K22   K31
>4 |3001  303  A   K13   K23   K33
>5 |4001  404  D   K14   K24   K34
>6 |5001  505  D   K15   K25   K35
>
>[Sheet2] ( ますた )
>  A   B   C   D    E    F
>1 |コード1 コード2 記号  項目1  項目2  項目3
>2 |1001  101  A   K11   K21   K31
>3 |3001  303  A   Z99   K23   R88
>4 |5001  505  D   K15   K25   K35
>
>[Sheet3] ( 結果 )
>  A   B   C   D    E    F    G
>1 |Sheet コード1 コード2 記号   項目1  項目2  項目3
>2 |1   1001  101  A    K11   K21   K31
>3 |2   1001  101  A    K11   K21   K31
>4 |1   2001  202  A    K12   K22   K31
>5 |2   *   *
>6 |1   3001  303  A    K13   K23   K33
>7 |2   3001  303  A    Z99   K23   R88
>8 |1   4001  404  D    K14   K24   K34
>9 |2   -   -
>10|1   5001  505  D    K15   K25   K35
>11|2   5001  505  D    K15   K25   K35
>
>
>1)「とらん」を1件づつ読込み、コード1とコード2をキーに「ますた」を検索し、
>
>  『とらん』「記号」="A"の場合
>  ◆存在した場合、項目1,2,3を比較し、「とらん」と「ますた」の情報を
>   [Sheet3]に結果を書き出します。
>   「ますた」に複数存在した場合は1件目のレコードで比較します。
>   アンマッチ項目があった場合、その項目のセルを赤く表示します。
>  ◆存在しなかった場合、「とらん」のレコードはそのまま[Sheet3]に
>   結果を書き出し、マスタのキーエリアに"*"を設定し、セルを赤く。
>
>  『とらん』「記号」="D"の場合
>  ◆存在しなかった場合、「とらん」のレコードはそのまま[Sheet3]に
>   結果を書き出し、「ますた」はキーエリアに"-"を設定します。
>  ◆存在した場合、[Sheet3]に結果を書き出します。
>   「ますた」に複数存在した場合は1件目のレコードで比較します。
>   アンマッチ項目があった場合、その項目のセルを赤く表示します。
>
>  以上を「とらん」のレコードがなくなるまで繰り返します。
> ※「とらん」は十件程度です。「とらん」がゼロ件の場合は処理を行いません
>
>----
シート名は 以下に示すコード内では、
 Sheet1、Sheet2、Sheet3にしてありますから、
 実際は違うのなら変更してください。


結果記述シートにあたるSheet3の1行目の項目名は予め入力して置いてください。


又、Sheet1のA列、B列のデータでSheet2を検索した結果、
見つからなかった場合の処理では、記号として半角大文字のAとDをみています。
(実際にはAしか調べていませんが、みていませんが・・・)
この辺りも実際には全角だったりした場合は、コードを変更してください。
尚、記号という項目には A、Dいずれかが入っているという想定です。


標準モジュールに
'==================================================================
Sub main()
  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, 7)).Value = sh1rng(idx).Resize(, 6).Value
       .Cells(idx * 2 + 1, 1).Value = 2
       If IsError(rw) Then
        If sh1rng(idx, 3).Value = "A" Then
          nsign = "*"
        Else
          nsign = "-"
          End If
        .Range(.Cells(idx * 2 + 1, 2), .Cells(idx * 2 + 1, 3)).Value = nsign
       Else
        .Range(.Cells(idx * 2 + 1, 2), .Cells(idx * 2 + 1, 7)).Value = sh2rng(rw).Resize(, 6).Value
        End If
       End With
     Next
    End If
End Sub

mainを実行してみてください。

私が確認した限りでは、ドルフィン さんが提示されたSheet1、Sheet2の
データを入力データとして試したところ、
Sheet3には、ドルフィン さんが記述された結果が得られました。

試してみてください。
2 hits

【44189】シート比較、ご教授下さいm( _ _ )m ドルフィン 06/11/7(火) 19:59 質問
【44193】Re:シート比較、ご教授下さいm( _ _ )m ichinose 06/11/8(水) 7:35 発言
【44197】Re:シート比較、ご教授下さいm( _ _ )m ドルフィン 06/11/8(水) 9:26 お礼

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