VBA code speed improvement to Search a column with 10K+ values find, remove and move value to another sheet

Greck71

New Member
Joined
Dec 14, 2017
Messages
3
I have had this working well until it grew so large it runs for a long time. What I would like it to do is:
Take the values on sheets (3_Create Scratch") range (I10:I109) and check for exact match on Sheets ("On Premise") range (A2:A10500) when an exact match is found remove the value from Sheets ("On Premise") and paste those values into sheets ("Excess") (A2:A2000) in the next available cell at bottom of the column. If no match is found move it to sheet ("Excess") anyways, Then clean up both sheets by sorting columns A to Z and removing any blanks. I hope there is a way to improve this. Thank you all in advance!

Sub MovetoExcess4()
Sheet4.Unprotect Password:="password"
Sheet6.Unprotect Password:="password"
Sheet7.Unprotect Password:="password"
Sheet8.Unprotect Password:="password"
Dim s3Rng As Range, c As Range, rngFound As Range
Dim iRow As Long, aRow As Long
iRow = Sheets("3_Create Scratch").Cells(Rows.Count, 9).End(xlUp).Row
aRow = Sheets("On Premise").Cells(Rows.Count, 1).End(xlUp).Row
Set s3Rng = Sheets("3_Create Scratch").Range("I10:I" & iRow)
For Each c In s3Rng
With Sheets("On Premise")

Set rngFound = Sheets("On Premise").Range("A2:A" & aRow).Find(What:=c, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)

If Not rngFound Is Nothing Then

rngFound.Cut Sheets("Excess").Range("A" & Rows.Count).End(xlUp)(2)

Else
'
End If



End With
Next

With Sheets("Excess").Columns("A")

.Sort key1:=.Cells(2, 1), order1:=xlAscending, Header:= _
xlYes, Orientation:=xlTopToBottom
End With

s3Rng = ""


Sheet4.Protect Password:="password"
Sheet6.Protect Password:="password"
Sheet7.Protect Password:="password"
Sheet8.Protect Password:="password"

'Range("A1").Select
'End With
'
End Sub
 

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.
One of the main reasons that Vba is slow is the time taken to access the worksheet from VBa is a relatively long time.
To speed up vba the easiest way is to minimise the number of accesses to the worksheet. What is interesting is that the time taken to access a single cell on the worksheet in vba is almost identical as the time taken to access a large range if it is done in one action.
So instead of writing a loop which loops down a range checking one row at a time which will take along time if you have got 10000 rows it is much quicker to load the 10000 lines into a variant array ( one worksheet access), then copy the lines to a variant array and then write the array back to the worksheet, ( one worksheet access for each search that you are doing),
I have a simple rule for fast VBA: NEVER ACCESS THE WORKSHEET IN A LOOP.
I have tired to rewrite your code using variant arrays but it is untested so undoubtedly there are errors but it should show you how to do it.
Code:
Sub MovetoExcess4()
Sheet4.Unprotect Password:="password"
Sheet6.Unprotect Password:="password"
Sheet7.Unprotect Password:="password"
Sheet8.Unprotect Password:="password"
Dim s3Rng As Variant
Dim Premis As Variant
Dim Xout As Variant


Dim iRow As Long, aRow As Long
iRow = Sheets("3_Create Scratch").Cells(Rows.Count, 9).End(xlUp).Row
aRow = Sheets("On Premise").Cells(Rows.Count, 1).End(xlUp).Row
s3Rng = Sheets("3_Create Scratch").Range("I10:I" & iRow)
ReDim Xout(1 To iRow - 9, 1 To 1)
' Load all the On premise data into a variant array 
Premis = Sheets("On Premise").Range("A2:A" & aRow)


indi = 1
For i = 1 To iRow - 9
  ' loop round to find a match
   For j = 1 To aRow - 1
      If s3Rng(i, 1) = Premis(j, 1) Then
      ' Match foudn so delete that row
      ' delete that row
        Premis(j, 1) = ""
        Exit For
      End If
   Next j
   ' copy to Excess
    Xout(indi, 1) = s3Rng(i, 1)
    indi = indi + 1
    
    '


' output the varaint array to excess
Xrow = Sheets("Excess").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Excess").Range(Cells(Xrow, 1), Cells(Xrow + indi, 1)) = Xout
 ' output the variant array back to premise with the blank in it
 
 Sheets("On Premise").Range("A2:A" & aRow) = Premis
 










With Sheets("Excess").Columns("A")


.Sort key1:=.Cells(2, 1), order1:=xlAscending, Header:= _
xlYes, Orientation:=xlTopToBottom
End With

This should take less than a second to run
 
Last edited:
Upvote 0
This makes total sense and I understand a little of the code but now I seem to be getting a Compile error "For without Next". Is this still requiring some sort of loop to end with.
 
Upvote 0
This makes total sense and I understand a little of the code but now I seem to be getting a Compile error "For without Next". Is this still requiring some sort of loop to end with.
It appears to be missing the matching "Next" statement for the "For i..." loop.
 
Upvote 0
As Joe4 correctly pointed it is missing the next i statement. this shows where it should be:
Code:
Sub MovetoExcess4()
Sheet4.Unprotect Password:="password"
Sheet6.Unprotect Password:="password"
Sheet7.Unprotect Password:="password"
Sheet8.Unprotect Password:="password"
Dim s3Rng As Variant
Dim Premis As Variant
Dim Xout As Variant




Dim iRow As Long, aRow As Long
iRow = Sheets("3_Create Scratch").Cells(Rows.Count, 9).End(xlUp).Row
aRow = Sheets("On Premise").Cells(Rows.Count, 1).End(xlUp).Row
s3Rng = Sheets("3_Create Scratch").Range("I10:I" & iRow)
ReDim Xout(1 To iRow - 9, 1 To 1)
' Load all the On premise data into a variant array
Premis = Sheets("On Premise").Range("A2:A" & aRow)




indi = 1
For i = 1 To iRow - 9
  ' loop round to find a match
   For j = 1 To aRow - 1
      If s3Rng(i, 1) = Premis(j, 1) Then
      ' Match foudn so delete that row
      ' delete that row
        Premis(j, 1) = ""
        Exit For
      End If
   Next j
   ' copy to Excess
    Xout(indi, 1) = s3Rng(i, 1)
    indi = indi + 1
Next i
    '




' output the varaint array to excess
Xrow = Sheets("Excess").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Excess").Range(Cells(Xrow, 1), Cells(Xrow + indi, 1)) = Xout
 ' output the variant array back to premise with the blank in it
 
 Sheets("On Premise").Range("A2:A" & aRow) = Premis
 
Last edited:
Upvote 0

Forum statistics

Threads
1,223,894
Messages
6,175,252
Members
452,623
Latest member
Techenthusiast

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top