| |
▼杏子 さん：
それでは、総入れ替えで。
比較タイトル規定、従来はA,B 一本でしたが、別々にそれぞれ規定します。
以下のコードでは、B のほうを契約金額としています。
もし違っていれば変更してください。
Sub Sample3()
Dim dicA As Object
Dim dicB As Object
Dim dicAonly As Object
Dim dicBonly As Object
Dim d As Variant
Dim colA() As Variant
Dim colB() As Variant
Dim shA As Worksheet
Dim shB As Worksheet
Dim c As Range
Dim vntTitleA As Variant
Dim vntTitleB As Variant
vntTitleA = Array("型名", "数量", "合価", "構成GC")
vntTitleB = Array("型名", "数量", "契約金額", "構成GC")
If UBound(vntTitleA) <> UBound(vntTitleB) Then
MsgBox "比較タイトル規定に関するプログラムエラーです。" & vbLf & _
"処理を終了します"
Exit Sub
End If
ReDim colA(1 To UBound(vntTitleA) + 1)
ReDim colB(1 To UBound(vntTitleB) + 1)
Set dicA = CreateObject("Scripting.Dictionary")
Set dicB = CreateObject("Scripting.Dictionary")
Set dicAonly = CreateObject("Scripting.Dictionary")
Set dicBonly = CreateObject("Scripting.Dictionary")
Set shA = Sheets("Sheet1")
Set shB = Sheets("Sheet2")
If Not GetCol(shA, colA, vntTitleA) Then Exit Sub
If Not GetCol(shB, colB, vntTitleB) Then Exit Sub
CreateDic shA, dicA, colA
CreateDic shB, dicB, colB
OnlyCheck shA, dicA, dicB, dicAonly, colA
OnlyCheck shB, dicB, dicA, dicBonly, colB
If dicAonly.Count = 0 Then
MsgBox "資料(A)にある内容はすべて資料(B)と同じでした"
Else
shA.Select
MsgBox "資料(A)のうち、以下が資料(B)にありません" & vbLf & Join(dicAonly.keys, vbLf)
End If
If dicBonly.Count = 0 Then
MsgBox "資料(B)にある内容はすべて資料(A)と同じでした"
Else
shB.Select
MsgBox "資料(B)のうち、以下が資料(A)にありません" & vbLf & Join(dicBonly.keys, vbLf)
End If
End Sub
Private Function GetCol(sh As Worksheet, v As Variant, vntT As Variant) As Boolean
Dim x As Long
Dim ck As String
Dim z As Variant
x = UBound(vntT) + 1
For x = 1 To x
ck = vntT(x - 1)
z = Application.Match(ck, sh.Rows(1), 0)
If IsError(z) Then
MsgBox sh.Name & "のタイトル行に" & ck & "がないので処理を終了します"
Exit Function
End If
v(x) = z
sh.UsedRange.Columns(z).Interior.ColorIndex = xlNone
Next
GetCol = True
End Function
Private Sub CreateDic(sh As Worksheet, dic As Object, v As Variant)
Dim c As Range
Dim sep As String
Dim d As Variant
Dim dKey As String
For Each c In sh.Range("A2", sh.Range("A" & sh.Rows.Count).End(xlUp))
dKey = ""
sep = ""
For Each d In v
dKey = dKey & sep & c.Offset(, d - 1).Value
sep = "/"
Next
dic(dKey) = c.Row
Next
End Sub
Private Sub OnlyCheck(sh As Worksheet, dic1 As Object, dic2 As Object, dicOnly As Object, v As Variant)
Dim d As Variant
Dim n As Variant
For Each d In dic1
If Not dic2.exists(d) Then
dicOnly(d) = True
For Each n In v
sh.Cells(dic1(d), n).Interior.Color = vbRed
Next
End If
Next
End Sub
|
|
UO3
- 12/8/21(火) 11:49 -
