Macro Help

[Dith2228]

I have two worksheets, Ws1 is my data worksheet and Ws2 is my reference worksheet. I need macro to search for all the names in Ws1 A and match if it is listed in my reference worksheet (ws2 column A) and will return the corresponding value of membership status from Ws2 Col B to Ws1 Col B. In below example, Ws1 under Membership Status, B2 must have a value "Not a member" and B3 as "Member" Please help as I am not good in macro and have thousand of members to run the macro through. I have been using excel with Index, Match and search in excel [=INDEX(Membership,Found,MATCH(TRUE,ISNUMBER(SEARCH(Name,M9)),0))] and it takes so much time considering the amount of data. Thank you in advance.

 

[mumps]

Try:

Sub CompareData()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, v As Variant, i As Long, Dic As Object, k As Variant
    Set desWS = Sheets("WS1")
    Set srcWS = Sheets("WS2")
    v1 = desWS.Range("A2", desWS.Range("A" & Rows.Count).End(xlUp)).Value
    v2 = srcWS.Range("A2", srcWS.Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value
    Set Dic = CreateObject("Scripting.Dictionary")
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v1, 1)
            Dic.Add v1(i, 1), i + 1
        Next i
        For i = 1 To UBound(v2, 1)
            For Each k In Dic.keys
                If InStr(1, k, v2(i, 1)) Then
                    desWS.Range("B" & Dic.Item(k)) = v2(i, 2)
                End If
            Next k
        Next i
    End With
    Application.ScreenUpdating = True
End Sub

 

[Dith2228]

Try:

Sub CompareData()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, v As Variant, i As Long, Dic As Object, k As Variant
    Set desWS = Sheets("WS1")
    Set srcWS = Sheets("WS2")
    v1 = desWS.Range("A2", desWS.Range("A" & Rows.Count).End(xlUp)).Value
    v2 = srcWS.Range("A2", srcWS.Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value
    Set Dic = CreateObject("Scripting.Dictionary")
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v1, 1)
            Dic.Add v1(i, 1), i + 1
        Next i
        For i = 1 To UBound(v2, 1)
            For Each k In Dic.keys
                If InStr(1, k, v2(i, 1)) Then
                    desWS.Range("B" & Dic.Item(k)) = v2(i, 2)
                End If
            Next k
        Next i
    End With
    Application.ScreenUpdating = True
End Sub

Hi mumps, thank you very much for your response. What about if there are multiple entries in WS1, A and the names are repeated, will this program keep working in returning the status?

 

[mumps]

Please post updated samples showing what you mean.

 

[Dith2228]

Try:

Sub CompareData()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, v As Variant, i As Long, Dic As Object, k As Variant
    Set desWS = Sheets("WS1")
    Set srcWS = Sheets("WS2")
    v1 = desWS.Range("A2", desWS.Range("A" & Rows.Count).End(xlUp)).Value
    v2 = srcWS.Range("A2", srcWS.Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value
    Set Dic = CreateObject("Scripting.Dictionary")
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v1, 1)
            Dic.Add v1(i, 1), i + 1
        Next i
        For i = 1 To UBound(v2, 1)
            For Each k In Dic.keys
                If InStr(1, k, v2(i, 1)) Then
                    desWS.Range("B" & Dic.Item(k)) = v2(i, 2)
                End If
            Next k
        Next i
    End With
    Application.ScreenUpdating = True
End Sub

Sorry I forgot to mention that there will be instances that there will be exact same entries like John Doe called for an appointment and it is returning an error

 

[mumps]

Please post sample data that shows all possibilities.

 

[Dith2228]

Sorry I forgot to mention that there will be instances that there will be exact same entries like John Doe called for an appointment and it is returning an error

 

[Dith2228]

Please post sample data that shows all possibilities.

Also, if a name does not exist, is it possible to just skip and move to the next entry?

 

[mumps]

Try:

Sub CompareData()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, v As Variant, i As Long, fnd As Range, sAddr As String
    Set desWS = Sheets("WS1")
    Set srcWS = Sheets("WS2")
    v = srcWS.Range("A2", srcWS.Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value
    For i = 1 To UBound(v, 1)
        Set fnd = desWS.Range("A:A").Find(v(i, 1), LookIn:=xlValues, lookat:=xlPart)
        If Not fnd Is Nothing Then
            sAddr = fnd.Address
            Do
                fnd.Offset(, 1) = v(i, 2)
                Set fnd = desWS.Range("A:A").FindNext(fnd)
            Loop While fnd.Address <> sAddr
            sAddr = ""
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

 

[Dith2228]

Try:

Sub CompareData()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, v As Variant, i As Long, fnd As Range, sAddr As String
    Set desWS = Sheets("WS1")
    Set srcWS = Sheets("WS2")
    v = srcWS.Range("A2", srcWS.Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value
    For i = 1 To UBound(v, 1)
        Set fnd = desWS.Range("A:A").Find(v(i, 1), LookIn:=xlValues, lookat:=xlPart)
        If Not fnd Is Nothing Then
            sAddr = fnd.Address
            Do
                fnd.Offset(, 1) = v(i, 2)
                Set fnd = desWS.Range("A:A").FindNext(fnd)
            Loop While fnd.Address <> sAddr
            sAddr = ""
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

Thank you so much! It worked like magic. Appreciate your help.