我的工作簿中有3张,其中2张包含相似的信息 - 相同的列但数据可能会有所不同。
因此,在A栏中有单位列表,然后在B栏中有内容,在C栏 - 温度,在D栏 - 目的地。
我要做的是比较2张数据,以显示表3中的所有不匹配 - 即如果单位号码(A)匹配,则查找内容(B)中的不匹配,温度(c)和目的地(D)。如果任何数据不同,请将它们从两张纸并排复印到第三张纸上。
然后,比较单位数字 - 如果在一张纸上找到一个数字但在另一张纸上找不到,则用红色突出显示,如果两个列表中的数字匹配,则以黄色突出显示或保持颜色相同。
这是我到目前为止所得到的:
Option Explicit
Const MySheet1 As String = "Sheet1" 'list 1
Const MySheet2 As String = "Sheet2" 'list 2
Const MySheet3 As String = "Sheet3" 'output sheet
Sub CompareLists()
Dim List1() As Variant, List2() As Variant
Dim LC1 As Long, LC2 As Long, ORow As Long
Dim Loop1 As Long, Loop2 As Long, Loop3 As Long
ORow = 4
With ThisWorkbook
LC1 = .Sheets(MySheet1).UsedRange.Rows.Count
LC2 = .Sheets(MySheet2).UsedRange.Rows.Count
List1 = .Sheets(MySheet1).Range("A1:D" & LC1).Value
List2 = .Sheets(MySheet2).Range("A1:D" & LC2).Value
For Loop2 = 2 To LC2
If Len(List2(Loop2, 3)) > 0 Then
List2(Loop2, 3) = Trim(List2(Loop2, 3))
End If
Next Loop2
With .Sheets(MySheet3)
.Cells.ClearContents
.Range("A1").Value = "Mismatched Records"
.Range("A3").Value = "Unit Number"
.Range("B2").Value = MySheet1
.Range("E2").Value = MySheet2
.Range("B3").Value = "Type"
.Range("C3").Value = "Required Temperature"
.Range("D3").Value = "Final Destination"
.Range("E3").Value = "Type"
.Range("F3").Value = "Required Temperature"
.Range("G3").Value = "Final Destination"
End With
For Loop1 = 2 To LC1
For Loop2 = 2 To LC2
If Trim(List1(Loop1, 1)) = Trim(List2(Loop2, 1)) Then
For Loop3 = 2 To 4
If Trim(List1(Loop1, Loop3)) <> Trim(List2(Loop2, Loop3)) Then
With .Sheets(MySheet3)
.Range("A" & ORow).Value = List1(Loop1, 1)
.Range("B" & ORow).Value = List1(Loop1, 2)
.Range("C" & ORow).Value = List1(Loop1, 3)
.Range("D" & ORow).Value = List1(Loop1, 4)
.Range("E" & ORow).Value = List2(Loop2, 2)
.Range("F" & ORow).Value = List2(Loop2, 3)
.Range("G" & ORow).Value = List2(Loop2, 4)
End With
ORow = ORow + 1
Exit For
End If
Next Loop3
Exit For
Else
DoEvents
End If
Next Loop2
Next Loop1
End With
MsgBox "Finished", vbInformation, "Done!"
End Sub
但是代码没有正常工作 - 即它没有列出输出表上的现有不匹配,也没有用红色突出显示不匹配的单位数。
答案 0 :(得分:1)
我看到的问题是你的数据比较是基于匹配的关键列。如果Sheet1的A列中存在一个值,而Sheet2的A列中不存在该值,则不会检查每个工作表的B到D列中的剩余值,也不会报告任何内容。明智地使用Exit For
后,比较关键列的For Each...Next Statement永远不会终止。如果确实如此,那么Sheet1的A列中有一些东西在Sheet2的A列中不存在,应该报告。
Option Explicit
Const MySheet1 As String = "Sheet1" 'list 1
Const MySheet2 As String = "Sheet2" 'list 2
Const MySheet3 As String = "Sheet3" 'output sheet
Sub CompareLists2()
Dim List1 As Variant, List2 As Variant
Dim LC1 As Long, LC2 As Long, ORow As Long
Dim Loop1 As Long, Loop2 As Long, Loop3 As Long
ORow = 4
With ThisWorkbook
LC1 = .Sheets(MySheet1).UsedRange.Rows.Count
LC2 = .Sheets(MySheet2).UsedRange.Rows.Count
List1 = .Sheets(MySheet1).Range("A1:D" & LC1).Value
List2 = .Sheets(MySheet2).Range("A1:D" & LC2).Value
For Loop2 = 2 To LC2
List2(Loop2, 3) = Trim(List2(Loop2, 3))
Next Loop2
With .Sheets(MySheet3)
.Cells.ClearContents
.Range("A1").Value = "Mismatched Records"
.Range("A3").Value = "Unit Number"
.Range("B2").Value = MySheet1
.Range("E2").Value = MySheet2
.Range("B3").Value = "Type"
.Range("C3").Value = "Required Temperature"
.Range("D3").Value = "Final Destination"
.Range("E3").Value = "Type"
.Range("F3").Value = "Required Temperature"
.Range("G3").Value = "Final Destination"
End With
For Loop1 = 2 To LC1
For Loop2 = 2 To LC2
If Trim(List1(Loop1, 1)) = Trim(List2(Loop2, 1)) Then
For Loop3 = 2 To 4
If Trim(List1(Loop1, Loop3)) <> Trim(List2(Loop2, Loop3)) Then
With .Sheets(MySheet3)
.Range("A" & ORow).Value = List1(Loop1, 1)
.Range("B" & ORow).Value = List1(Loop1, 2)
.Range("C" & ORow).Value = List1(Loop1, 3)
.Range("D" & ORow).Value = List1(Loop1, 4)
.Range("E" & ORow).Value = List2(Loop2, 2)
.Range("F" & ORow).Value = List2(Loop2, 3)
.Range("G" & ORow).Value = List2(Loop2, 4)
End With
ORow = ORow + 1
Exit For
End If
Next Loop3
Exit For
ElseIf Loop2 = LC2 Then
'last loop and no match
'this reports sheet1 missing from sheet2
With .Sheets(MySheet3)
.Range("A" & ORow).Value = List1(Loop1, 1)
.Range("B" & ORow).Value = List1(Loop1, 2)
.Range("C" & ORow).Value = List1(Loop1, 3)
.Range("D" & ORow).Value = List1(Loop1, 4)
End With
ORow = ORow + 1
End If
Next Loop2
Next Loop1
'add a reverse loop for Sheet2 column A keys missing from Sheet1's column A
For Loop2 = 2 To UBound(List2, 1)
For Loop1 = 2 To UBound(List1, 1)
If Trim(List1(Loop1, 1)) = Trim(List2(Loop2, 1)) Then
Exit For
ElseIf Loop1 = UBound(List1, 1) Then
'last loop and no match
'this reports sheet2 missing from sheet1
With .Sheets(MySheet3)
.Range("A" & ORow).Value = List2(Loop2, 1)
.Range("E" & ORow).Value = List2(Loop2, 2)
.Range("F" & ORow).Value = List2(Loop2, 3)
.Range("G" & ORow).Value = List2(Loop2, 4)
End With
ORow = ORow + 1
End If
Next Loop1
Next Loop2
End With
MsgBox "Finished", vbInformation, "Done!"
End Sub
我添加了一个半反向循环来捕获Sheet2 A列中未找到的在Sheet1的A列中找不到的键。