两表比对

yuhan4488

各位老师，工作簿中有sheet1和sheet2两个表，结构和数据基本一致但不完全一致。想对比两表找出不一致的位置。

以D列作为匹配列来匹配两表，D列相同的，则从sheet1中的A列到最后一列，和sheet2进行比对，比对出不同的内容用黄色显示单元格。
谢谢老师。

quqiyuan

参与一下，供参考。。。

quqiyuan

代码如下。。。
Sub test()
    Application.ScreenUpdating = False
    brr = Sheet1.[a1].CurrentRegion
    Sheet1.[a1].CurrentRegion.Interior.ColorIndex = 0
    Set d = CreateObject("scripting.dictionary")
    arr = Sheet2.[a1].CurrentRegion
    m = Application.Max(UBound(arr, 2), UBound(brr, 2))
    For i = 1 To UBound(arr)
        If Not d.exists(arr(i, 4)) Then d(arr(i, 4)) = i
    Next
    For i = 1 To UBound(brr)
        If d.exists(brr(i, 4)) Then
            For j = 1 To m
                If j <= UBound(arr, 2) Then
                    If brr(i, j) <> arr(d(brr(i, 4)), j) Then Sheet1.Cells(i, j).Interior.Color = vbYellow
                Else
                    Sheet1.Cells(i, j).Interior.Color = vbYellow
                End If
            Next
        Else
            Sheet1.Cells(i, 1).Resize(, m).Interior.Color = vbYellow
        End If
    Next
    Set d = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

3190496160

Sub 数据比对()
Dim ar As Variant, br As Variant
Dim rn As Range
Dim d As Object
Set d = CreateObject("scripting.dictionary")
ar = Sheet2.[a1].CurrentRegion
For i = 1 To UBound(ar)
    If ar(i, 4) <> "" Then
        d(ar(i, 4)) = i
    End If
Next i
With Sheet1
    .[a1].CurrentRegion.Interior.ColorIndex = 0
    br = .[a1].CurrentRegion
    For i = 1 To UBound(br)
        If br(i, 4) <> "" Then
            If Not d.exists(br(i, 4)) Then
                If rn Is Nothing Then
                    Set rn = .Cells(i, 1).Resize(1, 6)
                Else
                    Set rn = Union(rn, .Cells(i, 1).Resize(1, 6))
                End If
            Else
                xh = d(br(i, 4))
                For j = 1 To UBound(br, 2)
                    If j <= UBound(ar, 2) Then
                        If br(i, j) <> ar(xh, j) Then
                            If rn Is Nothing Then
                                Set rn = .Cells(i, j)
                            Else
                                Set rn = Union(rn, .Cells(i, j))
                            End If
                        Else
                            If rn Is Nothing Then
                                Set rn = .Cells(i, 6)
                            Else
                                Set rn = Union(rn, .Cells(i, 6))
                            End If
                        End If
                    End If
                Next j
            End If
        End If
    Next i
    If Not rn Is Nothing Then rn.Interior.ColorIndex = 6
End With
MsgBox "ok!"
End Sub

3190496160

两表比对.rar (15.79 KB, 下载次数: 11)

2024-6-29 10:17 上传

点击文件名下载附件

过客fppt

参与一下

过客fppt

过客fppt 发表于 2024-6-29 12:33
参与一下

Sub 根据标准表标出对比表的不同数据()
    Dim arr, brr, crr
    Dim i, j
    Dim rng As Range
    arr = ActiveWorkbook.Sheets("标准表").UsedRange
    brr = ActiveWorkbook.Sheets("对比表").UsedRange
    For i = LBound(arr) To UBound(arr)
        For j = LBound(arr, 2) To UBound(arr, 2)
            If Not arr(i, j) = brr(i, j) Then
                If rng Is Nothing Then
                    Set rng = ActiveWorkbook.Sheets("对比表").Cells(i, j)
                Else
                    Set rng = Union(Cells(i, j), rng)
                End If
            End If
        Next
    Next i
    rng.Interior.ColorIndex = 6
End Sub

yuhan4488

quqiyuan 发表于 2024-6-29 10:08
代码如下。。。
Sub test()
    Application.ScreenUpdating = False

这个代码很完美