Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

37607 / 76732

←次へ　｜　前へ→


	【44288】Re:シートの比較、ご教授下さい。（再記載）

ichinose - 06/11/12(日) 8:21 -


	引用なし

	パスワード

おはようございます。

以下のように変更してください。

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:
'　　　　　　　　　　　記号がDのときは、各項目比較は要らないのですか？
　　　　　　　　　 .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

プログラムって数学の数列のように規則性を見出せば、
ループ処理が使えますからね！！
（複雑なものはこれが発見できるか否かがキーポイントになります）

取り合えず、Sheet1のデータがSheet2に存在した場合、
しかも記号が　A　又は、U　の場合、

Sheet1とSheet2の項目1から項目8を比較
して一致しないセルのマスタ側のセルを赤く塗りつぶす
処理は出来ています。

試してみてください。

1 hits

▼

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