| |
▼ドルフィン さん：
おはようございます。
仕様書としては、わかりやすい記述ですね！！
次回からは、これにご自分が考えたコードも記述してください
そうするともっと勉強にはなると思いますよ！！
>どなたかご教示下さい。
>以下のようなSheet1とSheet2があります。
>この２つのシートを比較して、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とｺｰﾄﾞ2をキーに「ますた」を検索し、
>
> 『とらん』「記号」＝"A"の場合
> ◆存在した場合、項目1,2,3を比較し、「とらん」と「ますた」の情報を
> [Sheet3]に結果を書き出します。
> 「ますた」に複数存在した場合は１件目のレコードで比較します。
> アンマッチ項目があった場合、その項目のセルを赤く表示します。
> ◆存在しなかった場合、「とらん」のレコードはそのまま[Sheet3]に
> 結果を書き出し、マスタのキーエリアに"*"を設定し、セルを赤く。
>
> 『とらん』「記号」＝"D"の場合
> ◆存在しなかった場合、「とらん」のレコードはそのまま[Sheet3]に
> 結果を書き出し、「ますた」はキーエリアに"-"を設定します。
> ◆存在した場合、[Sheet3]に結果を書き出します。
> 「ますた」に複数存在した場合は１件目のレコードで比較します。
> アンマッチ項目があった場合、その項目のセルを赤く表示します。
>
> 以上を「とらん」のレコードがなくなるまで繰り返します。
> ※「とらん」は十件程度です。「とらん」がゼロ件の場合は処理を行いません
>
>----
シート名は 以下に示すコード内では、
Sheet1、Sheet2、Sheet3にしてありますから、
実際は違うのなら変更してください。
結果記述シートにあたるSheet3の１行目の項目名は予め入力して置いてください。
又、Sheet1のＡ列、Ｂ列のデータで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には、ドルフィン さんが記述された結果が得られました。
試してみてください。
|
|
ichinose
- 06/11/8(水) 7:35 -
