Excel如何实现两个工作表数据的对比

https://jingyan.baidu.com/article/63f236281f17650208ab3d97.html

 

Sub 数据对比()
    Dim i As Integer
    Dim j As Integer
    For i = 2 To 3225      \'员工基础报表数据范围
        For j = 2 To 2028    \'员工待遇统计表数据范围
         If Sheets("old").Cells(i, 6) = Sheets("new").Cells(j, 6) Then
               Sheets("old").Cells(i, 8) = "已存在"   \'存在时进行标记
         End If
        Next j
    Next i
End Sub

 

前面插入一列"Index"序号

Sub 数据对比()
    Dim i As Integer
    Dim j As Integer
    For i = 2 To 3225      \'员工基础报表数据范围
        For j = 2 To 2028    \'员工待遇统计表数据范围
         If Sheets("old").Cells(i, 7) = Sheets("new").Cells(j, 7) Then
               Sheets("old").Cells(i, 11) = "已存在"   \'存在时进行标记
               Sheets("new").Cells(j, 11) = "源表已存在"   \'存在时进行标记
               
               Sheets("old").Cells(i, 12) = i
               Sheets("new").Cells(j, 12) = i
         End If
        Next j
    Next i
End Sub

 

双重过滤，才能精准

Sub 数据对比()
    Dim i As Integer
    Dim j As Integer
    For i = 2 To 3225      \'员工基础报表数据范围
        For j = 2 To 2028    \'员工待遇统计表数据范围
         If Sheets("old").Cells(i, 4) = Sheets("new").Cells(j, 4) Then
            If Sheets("old").Cells(i, 7) = Sheets("new").Cells(j, 7) Then
               Sheets("old").Cells(i, 11) = "已存在"   \'存在时进行标记
               Sheets("new").Cells(j, 11) = "源表已存在"   \'存在时进行标记
               
               Sheets("old").Cells(i, 12) = i
               Sheets("new").Cells(j, 12) = i
            End If
        End If
        Next j
    Next i
End Sub

 

成功匹配：

Sub 数据对比()
    Dim i As Integer
    Dim j As Integer
    For i = 2 To 3225      \'员工基础报表数据范围
        For j = 2 To 2028    \'员工待遇统计表数据范围
         If Sheets("old").Cells(i, 4) = Sheets("new").Cells(j, 4) Then
            If Sheets("old").Cells(i, 7) = Sheets("new").Cells(j, 7) Then
               Sheets("old").Cells(i, 11) = "已存在"   \'存在时进行标记
               Sheets("new").Cells(j, 11) = "源表已存在"   \'存在时进行标记
               
               Sheets("old").Cells(i, 12) = i
               Sheets("new").Cells(j, 12) = i
            End If
        End If
        Next j
    Next i
End Sub

 

---

 

数值填充(大小写、双引号不能模糊匹配，需要改善)

Sub 数据对比()
    Dim i As Integer
    Dim j As Integer
    For i = 2 To 1362      \'源表
        For j = 2 To 1182    \'overlay表
         \'If Sheets("old").Cells(i, 4) = Sheets("new").Cells(j, 4) Then
            If Sheets("old").Cells(i, 1) = Sheets("new").Cells(j, 1) Then
               Sheets("old").Cells(i, 2) = Sheets("new").Cells(j, 2).Value   \'存在时进行标记
            End If
        \'End If
        Next j
    Next i
End Sub

 

改善后代码：

Option Compare Text
Sub 数据对比()
    Dim i As Integer
    Dim j As Integer
    For i = 2 To 1364      \'源表
        For j = 2 To 1183    \'overlay表
         \'If Sheets("old").Cells(i, 4) = Sheets("new").Cells(j, 4) Then
            If StrComp(Sheets("old").Cells(i, 1).Value, Sheets("new").Cells(j, 1).Value, 1) = 0 Then
               Sheets("old").Cells(i, 2) = Sheets("new").Cells(j, 2).Value   \'存在时进行标记
            End If
        \'End If
        Next j
    Next i
End Sub

或添加"Trim"函数过滤外侧空格

Option Compare Text
Sub 数据对比()
    Dim i As Integer
    Dim j As Integer
    For i = 2 To 1364      \'源表
        For j = 2 To 1183    \'overlay表
         \'If Sheets("old").Cells(i, 4) = Sheets("new").Cells(j, 4) Then
            If StrComp(Trim(Sheets("old").Cells(i, 1).Value), Trim(Sheets("new").Cells(j, 1).Value), 1) = 0 Then
               Sheets("old").Cells(i, 2) = Sheets("new").Cells(j, 2).Value   \'存在时进行标记
            End If
        \'End If
        Next j
    Next i
End Sub

 

再次改善代码，自动获取最后一行的长度

Option Compare Text
Sub 数据对比()
    Dim sLength As Integer \'记录源表长度
    Dim dLength As Integer \'记录目标表长度
    Dim i As Integer
    Dim j As Integer
    sLength = Sheets("old").Cells(Rows.Count, "A").End(xlUp).Row
    dLength = Sheets("new").Cells(Rows.Count, "A").End(xlUp).Row
    Debug.Print "source sheet length:" & sLength
    Debug.Print "dir sheet length:" & dLength
    
    For i = 2 To sLength
        For j = 2 To dLength
        \'If Sheets("old").Cells(i, 4) = Sheets("new").Cells(j, 4) Then
            If StrComp(Trim(Sheets("old").Cells(i, 1).Value), Trim(Sheets("new").Cells(j, 1).Value), 1) = 0 Then
               Sheets("old").Cells(i, 2) = Sheets("new").Cells(j, 2).Value   \'存在时进行标记
            End If
        \'End If
        Next j
    Next i

End Sub

 

再次改善：声明工作表引用类型

Option Explicit
Option Compare Text
Sub 数据匹配导入()
    \'声明语句
    Dim i As Integer
    Dim j As Integer
    Dim sLength As Integer \'源工作表长度
    Dim dLength As Integer \'目标工作表长度
    Dim sSheet As Sheet1 \'源工作表
    Dim dSheet As Sheet2 \'目标工作表
    
    \'赋值语句
    \'Set sSheet = Sheets("old") \'old是源工作表的名称
    \'Set dSheet = Sheets("new") \'new是目标工作表的名称
    Set sSheet = Sheets(1) \'第一个工作表
    Set dSheet = Sheets(2) \'第二个工作表
    
    \'获取工作表总列数
    sLength = sSheet.Cells(Rows.Count, "A").End(xlUp).Row
    dLength = dSheet.Cells(Rows.Count, "A").End(xlUp).Row

    \'打印总列数
    Debug.Print "source sheet length:" & sLength
    Debug.Print "dir sheet length:" & dLength
    
    Application.ScreenUpdating = False \'关闭屏幕更新
    For i = 2 To sLength \'第一行是标题行
        For j = 2 To dLength
            If StrComp(Trim(sSheet.Cells(i, 1).Value), Trim(dSheet.Cells(j, 1).Value), 1) = 0 Then
               sSheet.Cells(i, 2) = dSheet.Cells(j, 2).Value   \'将目标工作表的第二列赋值到源工作表的第二列
            End If
        Next j
    Next i
    Application.ScreenUpdating = True \'重新开启屏幕更新
    
    \'数据匹配完成后弹出提醒
    MsgBox "匹配完成！"
End Sub