利用Excel内嵌的搜索技术来实现高速查找重复值.doc

利用Excel内嵌的搜索技术来实现高速查找重复值
时间:2009-06-16 18:41:34来源:网络 作者:未知 点击:0次
Excel中可以实现搜索文本的功能，内嵌的优秀搜索算法可以快速的查找并定位一个特定的文本单元格，今天我使用VBA写了几行代码，实现了一个自动搜索并定位行功能的小程序！发现了Excel的这个优秀的属性，速度简直超级快！于是很快，
Excel中可以实现搜索文本的功能，内嵌的优秀搜索算法可以快速的查找并定位一个特定的文本单元格，今天我使用VBA写了几行代码，实现了一个自动搜索并定位行功能的小程序！发现了Excel的这个优秀的属性，速度简直超级快！于是很快，我就有了一个新想法，升级重复值校验程序的版本到V4.0！就使用Excel的这个属性来实现！于是乎说到不如做到！开始......，下面就公布这段代码，与各位网友共同研究：
'*************************************************************************
'                 全局查找资产号重复数据程序v4.0
'该程序通过遍历所有工作表查找表计资产号重复数据,将重复
'数据值拷贝到另一个工作表中并标注位置信息,重复值高亮显
'示,注意：该代码必须放到ThisWorkbook中执行,首尾设断点
'********
Public Sub FindAssetRepeat() '遍历查找资产号重复数据
Debug.Print "开始时间" & Format(Now, "yyyy年mm月dd日hh时mm分ss秒")
Dim i As Long, j As Long, k As Long, l As Long, m As Long, oi As Long
Dim maintemp As String, AssetColName As String
Dim ws As Worksheet, obj As Object, temprow As Long
oi = 1                          '标记结果工作表中初始的写入行号
AssetColName = "E"    '标识资产号所在的列的列名,如果档案的格式不同,可以修改该值
'****************************************************
'初始化重复值结果工作表开始
For i = 1 To Worksheets.Count   '先判断"重复值结果"工作表是否存在,如果存在则将句柄传给ws,并初始化
    If Worksheets(i).Name = "重复值结果" Then
        Set ws = Worksheets(i)
        ws.Move After:=Sheets(Worksheets.Count)
        ws.Cells.Select
        Selection.Delete Shift:=xlUp
        GoTo toBegin
    End If
Next i
Set ws = Worksheets.Add(After:=Sheets(Worksheets.Count))
ws.Name = "重复值结果"
toBegin:
ws.Activate
ws.Range("A" & oi & ":N" & oi).Select
ws.Range("A" & oi & ":N" & oi).Merge
ws.Range("A" & oi & ":N" & oi).Value = "表计资产号重复数据列表"
ws.Range("O" & oi).Value = "备注"
oi = oi + 1
ws.Cells.Select
Selection.NumberFormatLocal = "@"
ws.Cells(1, 1).Select
'初始化重复值结果工作表结束
'******************
'遍历所有表,开始查找重复值
For i = 1 To Worksheets.Count - 1
    For j = 2 To Worksheets(i).UsedRange.Rows.Count - 1
        maintemp = Trim(Worksheets(i).Range(AssetColName & j).Value)
        If maintemp = "" Then GoTo toNextRow   '如果其他工作表中的被校验行的资产号是非法数据,则跳到下一条
        If Asc(Left(maintemp, 1)) < 0 Or Asc(Left(maintemp, 1)) > 255 Then GoTo toNextRow   '功能同上
        '************************************
        '在当前工作表中查找重复值开始
        Worksheets(i).Activate
        Worksheets(i).Range(AssetColName & j + 1 & ":" & AssetColName & Worksheets(i).UsedRange.Rows.Count).Select
toBeginSearch1:
        Set obj = Selection.Find(What:=maintemp, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                 MatchCase:=False, MatchByte:=False, SearchFormat:=False)
        If Not (obj Is Nothing) Then
            obj.Activate
            temprow = ActiveCell.Row
            ws.Activate
            ws.Range("A" & oi & ":L" & oi).Value = Worksheets(i).Range("A" & j & ":L" & j).Value
            ws.Range("A" & oi + 1 & ":L" & oi + 1).Value = Worksheets(i).Range("A" & temprow & ":L" & temprow).Value
            ws.Range("M" & oi).Value = Worksheets(i).Name & "表中第" & j & "行"
            ws.Range("M" & oi + 1).Value = Worksheets(i).Name & "表中第" & temprow & "行"
            ws.Range("N" & oi & ":N" & oi + 1).Select
            ws.Range("N" & oi & ":N" & oi + 1).Merge
            ws.Range("N" & oi & ":N" & oi + 1).Value = "两行数据资产号重复"
            ws.Range(AssetColName & oi & ":" & AssetColName & oi + 1).Select
            Selection.Interior.ColorIndex = 3
            oi = oi + 3
            If temprow < Worksheets(i).UsedRange.Rows.Count - 1 Then
                Worksheets(i).Activate
                Worksheets(i).Range(AssetColName & temprow + 1 & ":" & AssetColName & Worksheets(i).UsedRange.Rows.Count).Select
                GoTo toBeginSearch1
            End If
        End If
        '在当前工作表中查找重复值结束
        '*******************************************
        '在其他工作表中查找重复值开始
        For l = i + 1 To Worksheets.Count - 1
            Worksheets(l).Activate
            Worksheets(l).Range(AssetColName & ":" & AssetColName).Select
toBeginSearch2:
            Set obj = Selection.Find(What:=maintemp, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                     MatchCase:=False, MatchByte:=False, SearchFormat:=False)
            If Not (obj Is Nothing) Then
                obj.Activate
                temprow = ActiveCell.Row
                ws.Activate
                ws.Range("A" & oi & ":L" & oi).Value = Worksheets(i).Range("A" & j & ":L" & j).Value
                ws.Range("A" & oi + 1 & ":L" & oi + 1).Value = Worksheets(l).Range("A" & temprow & ":L" & temprow).Value
                ws.Range("M" & oi).Value = Worksheets(i).Name & "表中第" & j & "行"
                ws.Range("M" & oi + 1).Value = Worksheets(l).Name & "表中第" & temprow & "行"
                ws.Range("N" & oi & ":N" & oi + 1).Select
                ws.Range("N" & oi & ":N" & oi + 1).Merge
                ws.Range("N" & oi & ":N" & oi + 1).Value = "两行数据资产号重复"
                ws.Range(AssetColName & oi & ":" & AssetColName & oi + 1).Select
                Selection.Interior.ColorIndex = 3
                oi = oi + 3
                If temprow < Worksheets(l).UsedRange.Rows.Count - 1 Then
                    Worksheets(l).Activate
                    Worksheets(l).Range(AssetColName & temprow + 1 & ":" & AssetColName & Worksheets(l).UsedRange.Rows.Count).Select
                    GoTo toBeginSearch2
                End If
            End If
            Worksheets(l).Cells(1, 1).Select
        Next l
        '在其他工作表中查找重复值结束
        '*****************
toNextRow:
    Next j
    Worksheets(i).Activate
    Worksheets(i).Cells(1, 1).Select
Next i
'查找重复值结束
'*******************************************************
'对查找出来的重复数据进行显示格式调整
ws.Activate
If oi = 2 Then
    ws.Range("A" & oi & ":N" & oi).Select
    ws.Range("A" & oi & ":N" & oi).Merge
    ws.Range("A" & oi & ":N" & oi).Value = "目前档案中暂未发现表计资产号重复数据"
    ws.Range("O" & oi).Value = "运气不错"
    ws.Range("A1:O" & oi).Select
    GoTo toEnd
End If
ws.Range("A1:O" & oi - 2).Select
toEnd:
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Borders(xlEdgeLeft).LineStyle = xlContinuous
    .Borders(xlEdgeTop).LineStyle = xlContinuous
    .Borders(xlEdgeRight).LineStyle = xlContinuous
    .Borders(xlEdgeBottom).LineStyle = xlContinuous
    .Borders(xlInsideVertical).LineStyle = xlContinuous
    .BordersxlInsideHorizontal).LineStyle = xlContinuous
End With
ws.Columns("A:O").Select
ws.Columns("A:O").EntireColumn.AutoFit
ws.Range("A1:N1").Select
Set ws = Nothing   '释放ws句柄
Debug.Print "结束时间" & Format(Now, "yyyy年mm月dd日hh时mm分ss秒")
'*******************************************************
End Sub
现在我的工作中有一个任务就是校验Excel工作表中是否有重复值出现，如果出现，就提取出来！v3.0的校验时间是：19987条数据->2小时30分钟，使用v4.0后，校验时间缩短到1小时48分钟，整整比v3.0快了近42分钟！

关键字：Excel内嵌搜索技术高速查找重复值