close match

[fi.or.jp.de]

Hi All,

I have two sheets ( sheet1 and sheet2)


Sheet1 Col A has Client name ( unique ) - Approximately 20,000 Rows


Sheet 2 Col A has Client name and Col B has Accounts - Approximately
100,000 Rows


I have created macro to look the Client name available in Sheet 1 col
A with Sheet2 col A,
If it matches then sheet2 Col B result will be populated in Sheet1
Col
A.
Below macro searches wtih wild card entry.


If Cell A2 ( sheet1) has = ABC
Sheet2 Col A has many names starts with ABC like ABC corp, ABC
Ltd,
Public ABC etc....


So, Sheet1 must have all the 3 accounts data in Col B.


Sub close_match()
Worksheets("sheet1").Activate
Set wb = Worksheets("sheet2")
Rng = Cells(Rows.Count, "A").End(xlUp).Row
rng1 = wb.Cells(Rows.Count, "A").End(xlUp).Row


For i = 2 To Rng
Cells(i, "A").Select
For a = 2 To rng1
If Cells(i, "A") Like wb.Cells(a, "A") Then
res = wb.Cells(i, "B")
result = result & "," & res
End If
Next a
With Application.WorksheetFunction
Cells(i, "B") = .Substitute(result, ",", "", 1)
End With
result = ""
Next i
End Sub


This macro is very slow, approximately for every minute it gives only
60 rows records.
As I have more 20,000 rows. The above needs to be changed in such
manner the work
need to be completed ASAP.


I kindly request all gurus of excel give me an suggestion run the
macro.


Thanks in advance.

 

[Barb Reinhardt]

I've tweaked, but can't test without real data. Try this

Option Explicit

Sub close_match()
Dim mySheet1 As Excel.Worksheet
Dim mySheet2 As Excel.Worksheet

Dim i As Long

Dim res As Variant
Dim result As Variant

Dim lRow As Long
Dim lRow1 As Long

Set mySheet1 = Worksheets("sheet1")
Set mySheet2 = Worksheets("sheet2")

lRow = mySheet1.Cells(Rows.Count, "A").End(xlUp).Row
lRow1 = mySheet2.Cells(Rows.Count, "A").End(xlUp).Row

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False


For i = 2 To lRow

'Cells(i, "A").Select
For a = 2 To lRow1
'Do the values in Sheet2 have * before and after to get the "like"
to work?
If mySheet1.Cells(i, "A") Like mySheet2.Cells(a, "A") Then
res = mySheet2.Cells(i, "B")
result = result & "," & res
End If
Next a
With Application.WorksheetFunction
mySheet1.Cells(i, "B") = .Substitute(result, ",", "", 1)
End With
result = ""
Next i

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub