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)
1 Answer 1
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
Sub ...and... End Sub\$\endgroup\$