Macro that uses a loop instead of match(), output not quit what I want

[Tim Hanson]

I was searching on how to get a faster matching code and came across a thread on a different forum that to use a looping function (which was posted) was 10x faster then using Match()

I am trying to piece together a macro that does this, I get the proper matching but the way it outputs the matched rows is not what I need.

I have attached a excel file with the code and a sheet that has the output and a sheet that has the desired output.

Thank you

Sub test1()
Dim arrS() As Variant
Dim arrT() As Variant
Dim myresult
Dim Destination As Range
Dim wsS As Worksheet
Dim wsT As Worksheet
Dim sLC As Long
Dim sLR As Long
Dim tLC As Long
Dim tLR As Long
Dim b As Long
Dim i As Long
Dim j As Long
Dim k As Long

Set wsS = ThisWorkbook.Sheets("YYY")
Set wsT = ThisWorkbook.Sheets("XXX")

With wsS
    sLC = .Cells(1, .Columns.Count).End(xlToLeft).Column
    sLR = .Range("A" & .Rows.Count).End(xlUp).Row
   arrS = .Range("A1").Resize(sLR, sLC)
  ReDim myresult(1 To UBound(arrS), 1 To UBound(arrS, 2))
End With

With wsT
    tLC = .Cells(1, .Columns.Count).End(xlToLeft).Column
    tLR = .Range("A" & .Rows.Count).End(xlUp).Row
   arrT = .Range("A2:A" & tLR).Value
End With

For i = 1 To UBound(arrS)
    b = Contains(arrT, arrS(i, 1))
        If b = True Then
              For k = 1 To UBound(arrS, 2)
                  myresult(i, k) = arrS(i, k)
              Next k
        End If
Next i

  'wsT.UsedRange.ClearContents
  wsT.Range("A1").Resize(UBound(arrS, 1), UBound(arrS, 2)).Offset(0, tLC) = myresult

End Sub

Function Contains(arrT, v) As Boolean
Dim rv As Boolean, lb As Long, ub As Long, i As Long
    lb = LBound(arrT)
    ub = UBound(arrT)
    For i = lb To ub
        If arrT(i, 1) = v Then
            rv = True
            Exit For
        End If
    Next i
    Contains = rv
End Function

 

[Somendra Misra]

Hi Tim,

Can't say what's wrong with your code, but can you test below code on your data.

Option Explicit

Sub testSM()

Dim wsourceSheet As Worksheet
Dim lookupSheet As Worksheet
Dim lrS As Long
Dim lrL As Long
Dim cntr As Long

Set wsourceSheet = ThisWorkbook.Worksheets("XXX")
Set lookupSheet = ThisWorkbook.Worksheets("YYY")

lrS = wsourceSheet.Cells(Rows.Count, 1).End(xlUp).Row
lrL = lookupSheet.Cells(Rows.Count, 1).End(xlUp).Row
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

For cntr = 2 To lrS
    If IsError(Application.Match(wsourceSheet.Range("A" & cntr), lookupSheet.Range("A2:A" & lrL), 0)) Then
        GoTo repeat
    Else
        lookupSheet.Range(lookupSheet.Cells(Application.Match(wsourceSheet.Range("A" & cntr), lookupSheet.Range("A2:A" & lrL), 0) + 1, 1), lookupSheet.Cells(Application.Match(wsourceSheet.Range("A" & cntr), lookupSheet.Range("A2:A" & lrL), 0) + 1, 5)).Copy wsourceSheet.Range("E" & cntr)
    End If
repeat:
Next cntr

With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
    .CutCopyMode = False
End With

       
End Sub

 

[Tim Hanson]

Somendra Misa thank you for your time and the code it works very well and I have added it to my library!

Though I am still hoping someone can figure out how to fix my code as I invested much time and thought in it and would like to know how to get it to work

Again, Thank you for the excellent macro

 

[p45cal]

Without code tags to highlight changes:

Sub test1()
Dim arrS() As Variant
Dim arrT() As Variant
Dim myresult
Dim Destination As Range
Dim wsS As Worksheet, wsT As Worksheet
Dim sLC As Long, sLR As Long, tLC As Long, tLR As Long, b As Long, i As Long, j As Long, k As Long, rw As Long

Set wsS = ThisWorkbook.Sheets("YYY")
Set wsT = ThisWorkbook.Sheets("XXX")
With wsS
sLC = .Cells(1, .Columns.Count).End(xlToLeft).Column
sLR = .Range("A" & .Rows.Count).End(xlUp).Row
arrS = .Range("A1").Resize(sLR, sLC)
End With
With wsT
tLC = .Cells(1, .Columns.Count).End(xlToLeft).Column
tLR = .Range("A" & .Rows.Count).End(xlUp).Row
arrT = .Range("A1:A" & tLR).Value
End With
ReDim myresult(1 To UBound(arrT), 1 To UBound(arrS, 2))
For i = 1 To UBound(arrT)
rw = 0
b = Contains(arrS, arrT(i, 1), rw)
If b = True Then
For k = 1 To UBound(arrS, 2)
myresult(i, k) = arrS(rw, k)
Next k
End If
Next i
wsT.Range("A1").Resize(UBound(arrT, 1), UBound(arrS, 2)).Offset(, tLC) = myresult
End Sub

Function Contains(arrX, v, idx) As Boolean
Dim rv As Boolean, lb As Long, ub As Long, i As Long
lb = LBound(arrX)
ub = UBound(arrX)
For i = lb To ub
If arrX(i, 1) = v Then
rv = True
idx = i
Exit For
End If
Next i
Contains = rv
End Function

idx added as argument to Contains function to record row in which a find was made.
arrT changed to arrX in Contains function to avoid (human) confusion.

myresult dimensions changed to number of rows on sheet XXX and number of columns on sheet YYY

The entire code in code tags:

Option Explicit

Sub test1()
Dim arrS() As Variant
Dim arrT() As Variant
Dim myresult
Dim Destination As Range
Dim wsS As Worksheet, wsT As Worksheet
Dim sLC As Long, sLR As Long, tLC As Long, tLR As Long, b As Long, i As Long, j As Long, k As Long, rw As Long

Set wsS = ThisWorkbook.Sheets("YYY")
Set wsT = ThisWorkbook.Sheets("XXX")
With wsS
  sLC = .Cells(1, .Columns.Count).End(xlToLeft).Column
  sLR = .Range("A" & .Rows.Count).End(xlUp).Row
  arrS = .Range("A1").Resize(sLR, sLC)
End With
With wsT
  tLC = .Cells(1, .Columns.Count).End(xlToLeft).Column
  tLR = .Range("A" & .Rows.Count).End(xlUp).Row
  arrT = .Range("A1:A" & tLR).Value
End With
ReDim myresult(1 To UBound(arrT), 1 To UBound(arrS, 2))
For i = 1 To UBound(arrT)
  rw = 0
  b = Contains(arrS, arrT(i, 1), rw)
  If b = True Then
    For k = 1 To UBound(arrS, 2)
      myresult(i, k) = arrS(rw, k)
    Next k
  End If
Next i
wsT.Range("A1").Resize(UBound(arrT, 1), UBound(arrS, 2)).Offset(, tLC) = myresult
End Sub
Function Contains(arrX, v, idx) As Boolean
Dim rv As Boolean, lb As Long, ub As Long, i As Long
lb = LBound(arrX)
ub = UBound(arrX)
For i = lb To ub
  If arrX(i, 1) = v Then
    rv = True
    idx = i
    Exit For
  End If
Next i
Contains = rv
End Function

 

[Tim Hanson]

Wow, I did not know I was so far away still from the answer.

arrT changed to arrX in Contains function to avoid (human) confusion.

I certainly had a lot of Human confusion going on

Thank you p45cal