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

Closed
upan275 - Dec 15, 2016 at 01:57 AM
Smallman1 Posts 5 Registration date Sunday December 18, 2016 Status Member Last seen December 21, 2016 - Dec 21, 2016 at 07:28 PM
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
Related:

3 responses

yg_be Posts 22692 Registration date Sunday June 8, 2008 Status Contributor Last seen April 16, 2024 5
Dec 15, 2016 at 02:29 PM
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.
0
upan275 Posts 4 Registration date Thursday December 15, 2016 Status Member Last seen December 21, 2016
Dec 18, 2016 at 03:23 AM
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..!
0
yg_be Posts 22692 Registration date Sunday June 8, 2008 Status Contributor Last seen April 16, 2024 5
Updated by yg_be on 18/12/16 at 05:48 AM
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?
0
upan275 Posts 4 Registration date Thursday December 15, 2016 Status Member Last seen December 21, 2016 > yg_be Posts 22692 Registration date Sunday June 8, 2008 Status Contributor Last seen April 16, 2024
Dec 19, 2016 at 07:38 AM
Fyi, i do have some identical values...but its alright as i can remove duplicates easily...
0
yg_be Posts 22692 Registration date Sunday June 8, 2008 Status Contributor Last seen April 16, 2024 5
Updated by yg_be on 18/12/16 at 06:32 AM
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
0
yg_be Posts 22692 Registration date Sunday June 8, 2008 Status Contributor Last seen April 16, 2024 5
Dec 18, 2016 at 05:59 AM
I believe
Loop Until IsEmpty(Sheets(1).Cells(x, "C"))
should be
Loop Until IsEmpty(Sheets(2).Cells(x, "A"))
0
Smallman1 Posts 5 Registration date Sunday December 18, 2016 Status Member Last seen December 21, 2016
Updated by Smallman1 on 18/12/16 at 06:12 PM
Hi


I had a friend ask me to solve the above for him, he was asking out of interest alone and I thought I would share the solution with the community. I wrote a blog post about it here where you can see a working version of the file.

https://www.thesmallman.com/blog/2016/12/16/compare-two-lists-on-different-sheets-and-ouput-matches

I had written similar blog posts in the past but this was specific to this particular thread.

The code is as follows and processes about 4.5K rows in less than half a second.



Option Explicit

Sub CompareSolve()
Dim i As Long
Dim j As Long
Dim ar As Variant

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)
n = n + 1
ar(n, j) = ar(i, j)
Next j
End If
Next i
End With
Sheet3.Cells(1).Resize(n, UBound(ar, 2)).Value = ar
End Sub





Take care

Smallman
0
vcoolio Posts 1404 Registration date Thursday July 24, 2014 Status Moderator Last seen September 15, 2023 259 > Smallman1 Posts 5 Registration date Sunday December 18, 2016 Status Member Last seen December 21, 2016
Dec 18, 2016 at 10:19 PM
@Smallman.

Thanks for the snippet. The code that you supplied is "weapons grade" stuff. Super efficient, super fast. The OP should have a massive smile on his/her face by now.

Cheerio,
vcoolio.
0
Smallman1 Posts 5 Registration date Sunday December 18, 2016 Status Member Last seen December 21, 2016 > vcoolio Posts 1404 Registration date Thursday July 24, 2014 Status Moderator Last seen September 15, 2023
Updated by vcoolio on 19/12/16 at 04:10 PM
LOL - we will see, mostly people just take and leave in my experience. Have a good Christmas VC!!!
0
upan275 Posts 4 Registration date Thursday December 15, 2016 Status Member Last seen December 21, 2016
Dec 19, 2016 at 07:35 AM
Hey Smallman1, you are same as your code...too fast to Judge people....Merry Christmas...Thanks for your help....Thanks all....
0
yg_be Posts 22692 Registration date Sunday June 8, 2008 Status Contributor Last seen April 16, 2024 5 > Smallman1 Posts 5 Registration date Sunday December 18, 2016 Status Member Last seen December 21, 2016
Dec 19, 2016 at 03:04 PM
@Smallman, what's the purpose of incrementing n in the "for j" loop?
0
upan275 Posts 4 Registration date Thursday December 15, 2016 Status Member Last seen December 21, 2016
Dec 21, 2016 at 01:39 AM
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
0
Smallman1 Posts 5 Registration date Sunday December 18, 2016 Status Member Last seen December 21, 2016
Dec 21, 2016 at 07:28 PM
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
0