Excel VBA重复检查器

时间:2018-11-05 19:43:05

标签: excel vba duplicates

**感谢所有有关如何以及“代码查看”部分的指针。今天,我转向为每个数字组制作一个数组来提取和比较数字。现在可以在几秒钟内完成工作,而不是几分钟。 **

我有有效的代码,它可以正常工作。目的是通过将ReadyForExport(通常约60行)表与PastLoanLog表(目前约1300行)一张一张地进行比较,来检查并报告是否有重复的借贷号。

问题:关于如何编写更好的代码的任何想法?运行需要几分钟,但是如果有一种方法可以使它运行得更快,那就是我要寻找的。这是代码:

Sub DupTest2()

'This runs through the RFE list, checks the 2nd mortgage numbers
'and reviews against the PastLoanLog spreadsheet

MsgBox ("This may take a minute")

OpenSheets 'Opens worksheets needed to run the program

Dim TestDpaNum As String
Dim PastDpaNum As String
Dim lRow As Integer
Dim DupNum As Integer
Dim h As Integer
Dim i As Integer
Dim lrowHFE As Integer

Sheets("ReadyForExport").Select
Range("G2").Select
lrowHFE = Cells(Rows.Count, 1).End(xlUp).Row
Debug.Print "Ready For Export LR " & lrowHFE


'Locate Last Row In PastLoanLog Data
'**********************************
Sheets("PastLoanLog").Select
Range("G2").Select
lRow = Cells(Rows.Count, 1).End(xlUp).Row


Sheets("ReadyForExport").Select
Range("G2").Select

    For h = 2 To lrowHFE

    'Finds the first loan number to check against the old data

    TestDpaNum = ActiveCell.Value

    Sheets("PastLoanLog").Select

    Range("G2").Select

            For i = 1 To lRow

            'Selects current cell to compare with cell from RFE sheet
            PastDpaNum = ActiveCell.Value

                If PastDpaNum = TestDpaNum Then
                    DupNum = DupNum + 1
                    Debug.Print "Duplicate Found" & TestDpaNum
                    Sheets("ErrorSheet").Range(DupNum, 6).Value = TestDpaNum
                    ActiveCell.Offset(1, 0).Select

                Else
                    ActiveCell.Offset(1, 0).Select

                End If

            Next

    Sheets("ReadyForExport").Select
    ActiveCell.Offset(1, 0).Select
    Debug.Print "CurrentRow=" & h

Next

'Sends the info to the Dashboard

Debug.Print "Dups = " & DupNum
Sheets("Dashboard").Select
Range("P16").Select
ActiveCell.Value = DupNum
ActiveCell.Offset(1, 0).Value = Now()
CloseSheets

End Sub

0 个答案:

没有答案