应用VBA进行Excel表之间的对比查找

　　在前面的进行WPS的安装率的统计中，使用两个FOR循环进行安装率的统计需要22秒以上，而使用一个FOR循环仅用了3秒，我是直接更改录制的宏进行程序的编写，后来发现时间只要耗费在sheet之间的跳转，这些是可以避免的。

　　也有其他的方法，就是通过if和vlookuo函数来做，但我暂时没有尝试，写程序来得快一些。

　　得到表中的行数也不需要录入，直接取值就行了。

　　比如：

Set srcSheet = Sheets(1)                      '第一个sheet
Set destSheet = Sheets(3)                     '第三个sheet
iSrcRow = srcSheet.[I65535].End(xlUp).Row     '源表的行数
iDestRow = destSheet.[I65535].End(xlUp).Row   '目标表的行数

　　上面也有等价的写法：

Set srcSheet = Sheets("WPS-Office安装记录-新")               '源表sheet
Set destSheet = Sheets("WPS-Office安装记录-前")              '目标表sheet
'得到源表和目标表的总行数
iSrcRow = srcSheet.Cells(Rows.Count, contrastColName).End(xlUp).Row
iDestRow = destSheet.Cells(Rows.Count, contrastColName).End(xlUp).Row

　　可以根据个人喜好来选择。

　　如果行数特别大，关闭屏幕更新和最小化窗口，等待程序执行完后恢复显示，这样也可以节约时间。

T1 = time()
Application.ScreenUpdating = False '关闭屏幕更新
Application.ActiveWindow.WindowState = xlMinimized    '最小化
......执行程序到完毕
Application.ScreenUpdating = False '开启屏幕更新
Application.ActiveWindow.WindowState = xlMaximized     '最大化
T2 = time()
Application.ScreenUpdating = False '开启屏幕更新
Application.ActiveWindow.WindowState = xlMaximized     '最大化
MsgBox "运行耗时：" + Str(timeDiff(T2, T1)) + " 秒"

　　计算时间差函数：

Function timeDiff(T2, T1)
'T2,T1为时间
'转换为秒
Dim second2 As Long
Dim second1 As Long
second2 = Hour(T2) * 3600 + Minute(T2) * 60 + Second(T2)
second1 = Hour(T1) * 3600 + Minute(T1) * 60 + Second(T1)
timeDiff = Abs(second2 - second1)
End Function

　　完整程序：

Sub Dawn1029()
'对比两个表的数据列进行检查
Dim iFor As Integer
Dim SYQCY As String
Dim S1, S2, S3, S4, S5, S6 As String
Dim allEquipment As Integer        '设备记录数
Dim ICOUNT As Integer
Dim DuplicateRecord As Integer     '重复记录数
Dim explainTxt As String           '说明文字
Dim installationRate As Single     '安装率
Dim findResult As Range            '检查结果
Dim notInstalled As Integer

T1 = time()
notInstalled = 0
DuplicateRecord = 0

Set srcTable = Sheets("注册总数-新")                      '总设备记录sheet
Set destTable = Sheets("WPS-Office安装记录-新")           'WPS安装记录sheet
allEquipment = srcTable.Cells(Rows.Count, "I").End(xlUp).Row
allWps = destTable.Cells(Rows.Count, "I").End(xlUp).Row

For iFor = 3 To allEquipment
    SYQCY = srcTable.Cells(iFor, "I").Value   '获取MAC地址
    S1 = Left(SYQCY, 2)
    S2 = Mid(SYQCY, 4, 2)
    S3 = Mid(SYQCY, 7, 2)
    S4 = Mid(SYQCY, 10, 2)
    S5 = Mid(SYQCY, 13, 2)
    S6 = Right(SYQCY, 2)
    SYQCY = S1 + S2 + S3 + S4 + S5 + S6
    Set findResult = destTable.Range("I:I").Find(SYQCY)
    If findResult Is Nothing Then
        '没有找到
        notInstalled = notInstalled + 1
        SResult = "没安装"
    Else
        '找到
        SResult = "★"
        '记录找到的次数，大于1就表示是重复的记录，对比MAC地址
        ICOUNT = Val(destTable.Cells(findResult.Row, "K").Value)
        ICOUNT = ICOUNT + 1
        If ICOUNT > 1 Then DuplicateRecord = DuplicateRecord + 1
        destTable.Cells(findResult.Row, "K").Value = ICOUNT
    End If
    srcTable.Cells(iFor, "W").Value = SResult
Next
T2 = time()
allWps = allWps - 2
allEquipment = allEquipment - 2
installationRate = allWps / (allEquipment - DuplicateRecord)
installationRate = Round(installationRate * 100, 2)
explainTxt = "　　　设备总记录：" + Str(allEquipment)
explainTxt = explainTxt + vbCrLf + "　　　WPS安装数：" + Str(allWps)
explainTxt = explainTxt + vbCrLf + "　　　重复记录数：" + Str(DuplicateRecord)
explainTxt = explainTxt + vbCrLf + "　　　WPS没安装数：" + Str(notInstalled)
explainTxt = explainTxt + vbCrLf + "　　　实际安装率：" + Str(installationRate) + "%"
explainTxt = explainTxt + vbCrLf + "　　　　运行耗时：" + Str(timeDiff(T2, T1)) + " 秒"
MsgBox explainTxt, , "检查结果 10月30日 19:22"
End Sub
Function timeDiff(T2, T1)
'T2,T1为时间
'转换为秒
Dim second2 As Long
Dim second1 As Long
second2 = Hour(T2) * 3600 + Minute(T2) * 60 + Second(T2)
second1 = Hour(T1) * 3600 + Minute(T1) * 60 + Second(T1)
timeDiff = Abs(second2 - second1)
End Function

　　结果显示：

 　　经过更改后的程序很快就出了结果，当然这也与个人计算机的配置有关。

　　后来增加功能，就是统计前后格式相同的两个表的数据变化，比如注册设备记录表，2个小时后有的记录消失了，有的记录是新增加的，要将这些记录找出来。

　　以下是完整程序：

Sub dawnCheckWpsInst()
    T1 = time()
    Dim srcMemo, destMemo As String
    '对比检查设备注册表
    srcMemo = contrastSheet("注册总数-新", "注册总数-前", "I", "X")
    '对比检查WPS安装记录表
    destMemo = contrastSheet("WPS-Office安装记录-新", "WPS-Office安装记录-前", "I", "L")
    
    '对比两个表的数据列进行检查：MAC地址（唯一值）
    Dim iFor As Integer
    Dim SYQCY As String
    Dim S1, S2, S3, S4, S5, S6 As String
    Dim allEquipment As Integer        '设备记录数
    Dim DuplicateRecord As Integer     '重复记录数
    Dim explainTxt As String           '说明文字
    Dim installationRate As Single     '安装率
    Dim findResult As Range            '检查结果
    Dim notInstalled As Integer
    Dim ICOUNT As Integer
    
    notInstalled = 0
    DuplicateRecord = 0
    
    Set srcTable = Sheets("注册总数-新")                            '总设备记录sheet
    Set destTable = Sheets("WPS-Office安装记录-新")                 'WPS安装记录sheet
    allEquipment = srcTable.Cells(Rows.Count, "I").End(xlUp).Row    '总设备的记录数
    allWps = destTable.Cells(Rows.Count, "I").End(xlUp).Row         'WPS安装记录数
    
    For iFor = 3 To allEquipment
        SYQCY = srcTable.Cells(iFor, "I").Value   '获取MAC地址
        S1 = Left(SYQCY, 2)
        S2 = Mid(SYQCY, 4, 2)
        S3 = Mid(SYQCY, 7, 2)
        S4 = Mid(SYQCY, 10, 2)
        S5 = Mid(SYQCY, 13, 2)
        S6 = Right(SYQCY, 2)
        SYQCY = S1 + S2 + S3 + S4 + S5 + S6
        Set findResult = destTable.Range("I:I").Find(SYQCY)
        If findResult Is Nothing Then
            '没有找到
            notInstalled = notInstalled + 1
            SResult = "没安装"
        Else
            '找到
            SResult = "★"
            '记录找到的次数，大于1就表示是重复的记录，对比MAC地址
            ICOUNT = Val(destTable.Cells(findResult.Row, "K").Value)
            ICOUNT = ICOUNT + 1
            If ICOUNT > 1 Then DuplicateRecord = DuplicateRecord + 1
            destTable.Cells(findResult.Row, "K").Value = ICOUNT
        End If
        srcTable.Cells(iFor, "W").Value = SResult
    Next
    T2 = time()
    allWps = allWps - 2
    allEquipment = allEquipment - 2
    installationRate = allWps / (allEquipment - DuplicateRecord)
    installationRate = Round(installationRate * 100, 2)
    explainTxt = "设备的总记录数：" + Str(allEquipment) + "　　比上一次检测：" + srcMemo
    explainTxt = explainTxt + vbCrLf + "WPS安装记录数：" + Str(allWps) + "　　比上一次检测：" + destMemo
    explainTxt = explainTxt + vbCrLf + "重复记录数：" + Str(DuplicateRecord)
    explainTxt = explainTxt + vbCrLf + "WPS没安装数：" + Str(notInstalled)
    explainTxt = explainTxt + vbCrLf + "实际安装率：" + Str(installationRate) + "%"
    explainTxt = explainTxt + vbCrLf + "　运行耗时：" + Str(timeDiff(T2, T1)) + " 秒"
    MsgBox explainTxt, , "检查结果 11月1日 10:35"
End Sub
Function timeDiff(T2, T1)
    'T2,T1为时间
    '转换为秒
    Dim second2 As Long
    Dim second1 As Long
    second2 = Hour(T2) * 3600 + Minute(T2) * 60 + Second(T2)
    second1 = Hour(T1) * 3600 + Minute(T1) * 60 + Second(T1)
    timeDiff = Abs(second2 - second1)
End Function

Function contrastSheet(srcSheetName, destSheetName, contrastColName, signColName)
    '对比检查格式相同的两个表的数据变化
    'contrastColName:对比的列名
    'signColName:做标记的列名
    Dim iSrcRow, iDestRow As Integer             '源表和目标表的总行数
    Dim iFor As Integer
    Dim sTemp As String
    Dim findResult As Range                      '检查结果
    Dim lookUpColName As String                  '搜索的列名
    Dim findCount As Integer                     '找到的记录数
    
    T1 = time()
    Application.ScreenUpdating = False                                         '关闭屏幕更新
    Application.ActiveWindow.WindowState = xlMinimized                         '最小化
    lookUpColName = contrastColName + ":" + contrastColName
    
    Set srcSheet = Sheets(srcSheetName)                                        '源表sheet
    Set destSheet = Sheets(destSheetName)                                      '目标表sheet
    iSrcRow = srcSheet.Cells(Rows.Count, contrastColName).End(xlUp).Row        '源表的总行数
    iDestRow = destSheet.Cells(Rows.Count, contrastColName).End(xlUp).Row      '目标表的总行数
    For iFor = 3 To iSrcRow
        srcSheet.Cells(iFor, signColName).Value = "新增加"
    Next
    For iFor = 3 To iDestRow
        destSheet.Cells(iFor, signColName).Value = "消失"
    Next
    For iFor = 3 To iSrcRow
        sTemp = srcSheet.Cells(iFor, contrastColName).Value
        Set findResult = destSheet.Range(lookUpColName).Find(sTemp)
        'SResult = "没安装"
        If findResult Is Nothing Then
            '没有找到
            notInstalled = notInstalled + 1
        Else
            '找到
            findCount = findCount + 1
            srcSheet.Cells(iFor, signColName).Value = "★"                    '修改源表记录
            destSheet.Cells(findResult.Row, signColName).Value = "★"                   '修改目标表的记录
        End If
    Next
    T2 = time()
    Application.ScreenUpdating = False '开启屏幕更新
    Application.ActiveWindow.WindowState = xlMaximized     '最大化
    '有标题栏和头部，所以从第3行开始的，总记录数应该减去2
    contrastSheet = "新增记录：" + Str(iSrcRow - findCount - 2) + "　　" + "消失记录：" + Str(iDestRow - findCount - 2)
End Function

　　经过运行，可以在源表中找到新增加的记录，在目标表中找到消失的记录。

　　显示结果：

　　在进行表之间的数据对比和处理时，可以使用Excel的函数，也可以使用下面的简单代码：

Sub 对比核查()
Dim findResult As Range             '检查结果
Dim iFor As Integer
Dim SResult As String               '检查结果字符串

Set srcSheet = Sheets("Sheet1")     '源表
Set destSheet = Sheets("Sheet2")    '目標表

'得到源表和目标表的总行数
iSrcRow = srcSheet.Cells(Rows.Count, "B").End(xlUp).Row
iDestRow = destSheet.Cells(Rows.Count, "B").End(xlUp).Row

For iFor = 2 To iSrcRow
    SYQCY = Trim(srcSheet.Cells(iFor, "B").Value)   '获取对比字段
    If SYQCY <> "" Then
        Set findResult = destSheet.Range("B:B").Find(SYQCY)
        If findResult Is Nothing Then
            '没有找到
            SResult = "?"
        Else
            '找到
            SResult = Str(findResult.Row)
            'ICOUNT = Val(destTable.Cells(findResult.Row, "K").Value)
            'destSheet.Cells(findResult.Row, "M").Value = "★" + Str(iFor)
        End If
        srcSheet.Cells(iFor, "A").Value = SResult
    End If
Next
MsgBox "检查完毕!"
End Sub