4
\$\begingroup\$

I want to compare (500) and find duplicate daily records within 2 sheets, and copy the unmatched row to another sheet, copy the match from another to 3rd sheet, and delete the matched records from original sheet.

I have 3 worksheets (results, Master List, Follow Ups) " results" update daily with 500 records, and added to "master list", duplicate row added to "follow ups"

All have similar columns heading A to O.

I want to compare Column B (unique) and column A of worksheet "results" to " Master List".

The flow would be:

  • Match a first cell value in column B of "results" to Column B cell values of " Master List"
    • If match found - compare column A of "results" to Column A cell values of " Master List"
  • If match found

    • Copy the row of match from "Master List" for Column A to O to next available row of "Follow Ups"
    • Mark the match row in "results" to be deleted in the end when search loop finished
  • Else if match not found

    • check next value in column B of " result" until last record
  • When whole search ends, delete marked records for match found in "results" and copy all the left out records to Next available table row in "Master List".

I am kind of stuck and don't want to run in long loop, looking for expert help with shortest and fastest possible code. Here is some code already written and working, but not working well.

If possible optional approach (can both column value jointly compared with another sheet):

Set sht1 = xlwb.Worksheets("results")
    Set sht4 = xlwb.Worksheets("Master List")
    Set sht5 = xlwb.Worksheets("Follow Ups")

    For i = 2 To sht1.Range("A1").SpecialCells(xlCellTypeLastCell).Row
            For j = 2 To sht4.Range("A1").SpecialCells(xlCellTypeLastCell).Row
                    If sht1.Cells(i, 2) = sht4.Cells(j, 2) And sht1.Cells(i, 1) = sht4.Cells(j, 1) Then

                    'sht4.Rows(j).Copy
                   ' sht5.Activate

                    'sht5.Cells(1, sht5.Range("A1").SpecialCells(xlCellTypeLastCell).Row).Select



                    sht4.Rows(j).Copy _
                    Destination:=sht5.Cells(sht5.Range("A1").SpecialCells(xlCellTypeLastCell).Row + 1, 1)



                        'sht1.Rows(i).Delete

                        'i = i - 1
                     End If

            Next
    Next



sht1.Range("A2:O" & sht1.Range("A1").SpecialCells(xlCellTypeLastCell).Row).Copy Destination:=sht4.Cells(sht4.Range("A1").SpecialCells(xlCellTypeLastCell).Row, 1)
\$\endgroup\$
  • 3
    \$\begingroup\$ Would you mind including the code of the entire procedure? (Everything betweenSub ... and ... End Sub \$\endgroup\$ – Kaz Jun 12 '16 at 12:44
  • \$\begingroup\$ superuser.com/questions/1088292/… \$\endgroup\$ – Raystafarian Jun 14 '16 at 12:09
  • \$\begingroup\$ Perhaps consider using SQL for this. Use ADODB and write two left joins (with tables swapped) to get the non matching data you are after. To get matches, use Inner Join. \$\endgroup\$ – Ryan Wildry Jun 15 '16 at 13:35
6
\$\begingroup\$

First things first, you have to figure out what your code is doing. You need to break your code up into little steps. Make sure each step makes sense and is done well. Then, you can start combining them in useful ways because it's clear what your code is doing and how.

Only then can you start really improving performance. Trying to do so before you have a clear idea of what your code is doing and how is a bad idea.


#1: Take your workbook/sheets and give them proper, descriptive names

Dim targetBook As Workbook
Set targetBook = '/ whatever xlwb is

With targetBook

    Dim resultsSheet As Worksheet
    Set resultsSheet = targetBook.Sheets("results")

    Dim masterSheet As Worksheet
    Set masterSheet = targetBook.Sheets("Master List")

    Dim followUpSheet As Worksheet
    Set followUpSheet = targetBook.Sheets("Follow Ups")

End With

#2: Find your end rows and put them in properly named variables

Dim resultsFinalRow As Long
With resultsSheet
    resultsFinalRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With

Dim masterFinalRow As Long
With masterSheet
    masterFinalRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With

Dim followUpFinalRow As Long
With followUpSheet
    followUpFinalRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With

Dim isMatch As Boolean
Dim resultsRow As Long
Dim masterRow As Long
For resultsRow = 2 To resultsFinalRow
    For masterRow = 2 To masterFinalRow

    ...

#3 Lay the framework for your loop

Dim isMatch As Boolean
Dim resultsRow As Long
Dim masterRow As Long
For resultsRow = 2 To resultsFinalRow
    For masterRow = 2 To masterFinalRow

        isMatch = (resultsSheet.Cells(resultsRow, 2) = masterSheet.Cells(masterRow, 2)) _
                And (resultsSheet.Cells(resultsRow, 1) = masterSheet.Cells(masterRow, 1))

        If isMatch Then

            '/ Do Stuff

        End If

    Next masterRow
Next resultsRow

#4: Flesh out your loop logic

Rather than remembering which rows to delete at the end, just delete them as you go. Keeps things nice and clean.

Dim copyRange As Range
Dim isMatch As Boolean
Dim matchFound As Boolean
Dim resultsRow As Long
Dim masterRow As Long
For resultsRow = 2 To resultsFinalRow

    matchFound = False

    For masterRow = 2 To masterFinalRow

        isMatch = (resultsSheet.Cells(resultsRow, 2) = masterSheet.Cells(masterRow, 2)) _
                And (resultsSheet.Cells(resultsRow, 1) = masterSheet.Cells(masterRow, 1))

        If isMatch Then

            matchFound = True

            With masterSheet
                Set copyRange = .Range(.Cells(masterRow, 1), .Cells(masterRow, 15))
            End With

            copyRange.Copy Destination:=followUpSheet.Cells(followUpRow, 1)
            followUpRow = followUpRow + 1

        End If

    Next masterRow

    If matchFound Then
        resultsSheet.Rows(resultsRow).Delete
        resultsRow = resultsRow - 1
    End If

Next resultsRow

#5: Clean Up

With resultsSheet

    resultsFinalRow = .Cells(.Rows.Count, 1).End(xlUp).Row '/ find new final row

    Set copyRange = .Range(.Cells(1, 1), .Cells(resultsFinalRow, 15))
    copyRange.Copy Destination:=masterSheet.Cells(masterFinalRow + 1, 1)

End With

Now we have a sub that's actually pretty clear and understandable:

Option Explicit

Public Sub CRquestion()

    Dim targetBook As Workbook
    Set targetBook = "" '/ whatever xlwb is

    With targetBook

        Dim resultsSheet As Worksheet
        Set resultsSheet = targetBook.Sheets("results")

        Dim masterSheet As Worksheet
        Set masterSheet = targetBook.Sheets("Master List")

        Dim followUpSheet As Worksheet
        Set followUpSheet = targetBook.Sheets("Follow Ups")

    End With

    Dim resultsFinalRow As Long
    With resultsSheet
        resultsFinalRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With

    Dim masterFinalRow As Long
    With masterSheet
        masterFinalRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With

    Dim followUpFinalRow As Long
    With followUpSheet
        followUpFinalRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With

    Dim followUpRow As Long
    followUpRow = followUpFinalRow + 1 '/ next empty follow up row

    Dim copyRange As Range
    Dim isMatch As Boolean
    Dim matchFound As Boolean
    Dim resultsRow As Long
    Dim masterRow As Long
    For resultsRow = 2 To resultsFinalRow

        matchFound = False

        For masterRow = 2 To masterFinalRow

            isMatch = (resultsSheet.Cells(resultsRow, 2) = masterSheet.Cells(masterRow, 2)) _
                    And (resultsSheet.Cells(resultsRow, 1) = masterSheet.Cells(masterRow, 1))

            If isMatch Then

                matchFound = True

                With masterSheet
                    Set copyRange = .Range(.Cells(masterRow, 1), .Cells(masterRow, 15))
                End With

                copyRange.Copy Destination:=followUpSheet.Cells(followUpRow, 1)
                followUpRow = followUpRow + 1

            End If

        Next masterRow

        If matchFound Then
            resultsSheet.Rows(resultsRow).Delete
            resultsRow = resultsRow - 1
        End If

    Next resultsRow

    With resultsSheet

        resultsFinalRow = .Cells(.Rows.Count, 1).End(xlUp).Row

        Set copyRange = .Range(.Cells(1, 1), .Cells(resultsFinalRow, 15))
        copyRange.Copy Destination:=masterSheet.Cells(masterFinalRow + 1, 1)

    End With

End Sub

Performance Improvements


Standard VBA Tune Ups

The lowest-hanging VBA performance fruit are ScreenUpdating, EnableEvents and Calculation.

Application.ScreenUpdating = False
Application.EnableEvents= False
Application.Calculation= XlManual

...

Code

...

Application.ScreenUpdating = True
Application.EnableEvents= True
Application.Calculation= XlAutomatic

Every time you access the worksheet, events trigger, formulas recalculate and Turning those options off will make your code inordinately faster. Just make sure they get reset back to normal at the end.


Delete all in one go

To iteratively build a list of rows to delete, then delete them all at once, the best way is to use Range.Union(). So you create a range then, whenever you find a row to delete, add that row to your range. At the end, take your compound range and call Range.EntireRow.Delete once to do the whole thing in one operation.

This would modify the code like so:

        Next masterRow

        If matchFound Then
            If deleteRange Is Nothing Then

                '/ for the first time we set the range
                Set deleteRange = resultsSheet.Cells(resultsRow, 1)

            Else

                '/ add the current row to our range
                Set deleteRange = Union(deleteRange, resultsSheet.Cells(resultsRow, 1))

            End If
        End If

    Next resultsRow

    If Not deleteRange Is Nothing Then deleteRange.EntireRow.Delete
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.