| |
▼杏子 さん：
こんばんは
野暮用がが早く片付いたのでコードを書きました。
ややこしくなるので一式、アップします。すべていれかえてください。
なお、
vntTitleA = Array("型名", "数量", "合価|契約金額|金額", "構成GC")
vntTitleB = Array("型名", "数量", "契約金額", "構成GC")
これで資料Aと資料Bの、それぞれ対になるタイトルを規定しますが、可能性として複数あるものは
資料Aであれ資料Bであれ、また、どのタイトル項目であれ、"●●|■■|△△|□□" といったように
| で区切って指定します。
また、上記例では、比較列は4組ですが、必要なだけ何組でも記述可能です。
Sub Sample4()
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 Long
Dim headStr As String
Dim w As Variant
Dim wStr As String
Dim n As Long
headStr = vbTab & Join(WorksheetFunction.Index(sh.Range("A1", sh.Cells(1, sh.Columns.Count).End(xlToLeft)).Value, 1, 0), vbTab) & vbTab
With CreateObject("VBScript.RegExp")
x = UBound(vntT) + 1
For x = 1 To x
ck = vntT(x - 1)
.Pattern = vbTab & "(" & ck & ")" & vbTab
With .Execute(headStr)
If .Count = 0 Then
z = 0
Else
n = .Item(0).firstindex + 1
wStr = Left(headStr, n)
z = Len(wStr) - Len(Replace(wStr, vbTab, ""))
End If
End With
If z = 0 Then
MsgBox sh.Name & "のタイトル行に" & ck & "がないので処理を終了します"
Exit Function
End If
v(x) = z
sh.UsedRange.Columns(z).Interior.ColorIndex = xlNone
Next
End With
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(火) 20:40 -
