Any faster version of the same code to handle 5000+ records

Closed
Report
-
Posts
5
Registration date
Sunday December 18, 2016
Status
Member
Last seen
December 21, 2016
-
Hello,

May i plz get a faster code for the same?
currently for around 5000+ records this code takes around 10 minutes...

i.e. Match all the cellvalues of col A of sheet1 to all cellvalues in sheet 2 col C

If match then copy matched cell's entire raw in sheet 3...

Also i want to add: highlight all matched cell values in both sheet..if possble & without increasing process time....a lot...

Thanks in advance

Sub RunMe_loaddata()


Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'tried to increase speed didn't work..!

Dim lRow, x As Long

Sheets(1).Select
lRow = Range("C1").End(xlDown).Row

For Each cell In Range("C2:C" & lRow)
x = 2
Do
If cell.Value = Sheets(2).Cells(x, "A").Value Then
cell.EntireRow.Copy Sheets("Sheet4").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End If
x = x + 1
Loop Until IsEmpty(Sheets(1).Cells(x, "C"))
Next

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

3 replies

Posts
17787
Registration date
Sunday June 8, 2008
Status
Contributor
Last seen
December 8, 2021
5
Highlighting the matched cells is easy. Simply add this in the if section, after the copy:
cell.Interior.Color = 65535
Sheets(2).Cells(x, "A").Interior.Color = 65535

Improving the algorithm will require some VBA skills, and some time to use those skills. Are you prepared to spend time to learn that? If yes, I can provide some guidance.
The general idea would be to do the matching on sorted values. This is what you would do in real life, if you had to match two large sets of values, such as two sets of 1000 cards with a word on each card.
Posts
4
Registration date
Thursday December 15, 2016
Status
Member
Last seen
December 21, 2016

Hi,

Thanks for the highlighting code.
RE:Improving the algorithm will require some VBA skills, and some time to use those skills. Are you prepared to spend time to learn that? If yes, I can provide some guidance. 

Yes I do.Please shoot at me...I'ii try my level best....

Cannot understand what do you exactly mean by Sorting Algorithm though....My data is 5000+ records and majority of them are alphanumerical & sorted in ascending order in excel..!
Posts
17787
Registration date
Sunday June 8, 2008
Status
Contributor
Last seen
December 8, 2021
5
The data in both sheets is already sorted (based on the columns you compare)?
Then you can "easily" do something much faster; I am preparing suggestions.
Are your values unique, or can you have several identical values in the columns you compare?
Posts
4
Registration date
Thursday December 15, 2016
Status
Member
Last seen
December 21, 2016
>
Posts
17787
Registration date
Sunday June 8, 2008
Status
Contributor
Last seen
December 8, 2021

Fyi, i do have some identical values...but its alright as i can remove duplicates easily...
Posts
17787
Registration date
Sunday June 8, 2008
Status
Contributor
Last seen
December 8, 2021
5
Proposal :
option explicit
Sub RunMe_loaddata()

dim lC as long, lA as long
' lC is row number in sheet1, where the column of interest is C
' lA is row number in sheet2, where the column of interest is A

Sheets(1).Select

lC=2 
lA=2
do while not (isempty(Cells(lC,"C")) or isempty(Sheets(2).Cells(lA, "A"))) 
        If Cells(lC,"C").Value = Sheets(2).Cells(lA, "A").Value Then
                  Cells(lC,"C").EntireRow.Copy _
                      Sheets("Sheet4").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                 Cells(lC,"C").Interior.Color = 65535
                 Sheets(2).Cells(lA, "A").Interior.Color = 65535
  ' assuming that values are unique, we can move to next rows in both sheets
                 lA=lA+1
                 lC=lC+1
       else
                 If Cells(lC,"C").Value < Sheets(2).Cells(x, "A").Value Then
                         lC=lC+1
                 else
                         lA=lA+1
                 end if
        End If
Loop 'while not (isempty(Cells(lC,"C")) or isempty(Sheets(2).Cells(x, "A")))

End Sub
Posts
17787
Registration date
Sunday June 8, 2008
Status
Contributor
Last seen
December 8, 2021
5
I believe
Loop Until IsEmpty(Sheets(1).Cells(x, "C"))
should be
Loop Until IsEmpty(Sheets(2).Cells(x, "A"))
Posts
5
Registration date
Sunday December 18, 2016
Status
Member
Last seen
December 21, 2016
>
Posts
1326
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
November 28, 2021

LOL - we will see, mostly people just take and leave in my experience. Have a good Christmas VC!!!
Posts
17787
Registration date
Sunday June 8, 2008
Status
Contributor
Last seen
December 8, 2021
5 >
Posts
5
Registration date
Sunday December 18, 2016
Status
Member
Last seen
December 21, 2016

@Smallman, what's the purpose of incrementing n in the "for j" loop?
Posts
4
Registration date
Thursday December 15, 2016
Status
Member
Last seen
December 21, 2016

Hey Smallman1, you are same as your code...too fast to Judge people....Merry Christmas...Thanks for your help....Thanks all....
Posts
5
Registration date
Sunday December 18, 2016
Status
Member
Last seen
December 21, 2016

Upan275 - it was just an observation after many years of helping out on forums. There is no judgement in my remark - please read it again. Have a good Christmas too.
Posts
5
Registration date
Sunday December 18, 2016
Status
Member
Last seen
December 21, 2016

Hi yg_be

When transposing code to my site I have to do it line by line to add colour and text incrementing. Sometimes I transpose it incorrectly. It is a painful process - It should have read.

Sub CompSolve() 
Dim ar As Variant
Dim i As Long
Dim j As Long
Dim n As Long

ar = Sheet2.Cells(1, 3).CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(ar, 1)
.Item(ar(i, 1)) = Empty
Next
ar = Sheet1.Cells(1).CurrentRegion.Value
n = 1

For i = 2 To UBound(ar, 1)
If .exists(ar(i, 1)) Then
n = n + 1
For j = 1 To UBound(ar, 2)
ar(n, j) = ar(i, j)
Next
End If
Next
End With
Sheet3.Cells(1, 1).Resize(n, UBound(ar, 2)).Value = ar
End Sub


where the n increment is only once. I suspect people ran the file not the above. I have changed the code on my site and above it should be fine. Thanks for alerting me to this.

Take care

Smallman
Posts
4
Registration date
Thursday December 15, 2016
Status
Member
Last seen
December 21, 2016

Hello All,

During Trials to customize code as per my requirement. (I.E.column selection as Msg Box for user to select) I notice a weirdo problem.
When i select a data in Sht2 next to Col C Outcome is always Headers only. As soon as I make blank columns both side of Column C,I get desired Result.
Fyi,I am using SmallMan1’s Template. Thanks for the wonderful site mate!
Option Explicit

Sub DicSolve() 'Excel VBA find duplicates with the scripting dictionary.
Dim ar As Variant
Dim i As Long
Dim j As Long
Dim n As Long

ar = Sheet2.Cells(1, 3).CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(ar, 1)
.Item(ar(i, 1)) = Empty
Next
ar = Sheet1.Cells(1).CurrentRegion.Value
n = 1

For i = 2 To UBound(ar, 1)
If .exists(ar(i, 1)) Then
n = n + 1
For j = 1 To UBound(ar, 2)
ar(n, j) = ar(i, j)
Next
End If
Next
End With
Sheet3.Cells(10, 1).Resize(n, UBound(ar, 2)).Value = ar
End Sub
Posts
5
Registration date
Sunday December 18, 2016
Status
Member
Last seen
December 21, 2016

Hi Upan275

Thanks for the reply. Mmmm I can't seem to replicate your issue - no bother - if you send me your file with some instructions on what you want to achieve I will customise it for you - it is Christmas after all.

My email is MarcusSmallATTLESthesmallman.com Obvo replace ATTLES with the @ symbol : )

Take care

Smallman