Validate cells in column A with info from other columns

[Shywawa]

Hi,

I am trying to validate with OK/CHECK values from column A. The result goes into column B for each value in Row A.
The values I am trying to do the validation come from 2 different columns ( G and H).

For Example:

Column A has a variety of Last Name + First Name combinations written in all possible forms (John Deer; Deer, John; Deer John; Acapulco hotel Deer John)
Columns G and H are first Name Last Name of the people that are valid and which i need to do the validation for. needles to say these 2 need to be from the same row.

The code i wrote so far is the one below but unfortunately the result is CHECK from top to bottom. I have a feeling i am doing something very wrong with the info coming from G and H.

Sub Match()

Dim cell As Range


 For Each cell In Columns("A").Cells.SpecialCells(xlCellTypeConstants)

    If InStr(Cells(cell.Row, "A"), Cells(cell.Column, "H")) > 0 And _
    InStr(Cells(cell.Row, "A"), Cells(cell.Column, "I")) > 0 Then
          
       
     Cells(cell.Row, "B") = "OK"
     
     Else
     
     Cells(cell.Row, "B") = "Check"
     
     
End If
Next cell


End Sub

Let me know if you need a sample of the file.

Kind regards,
Shywawa

[mancubus]

post your workbook pls.

[georgiboy]

Hi there

I am on my phone so can’t test code but looking at this I would ask:

Does the function Instr require values of a cell or a string to look at?

The code above is passing the cell itself to Instr and may cause issues.

Hope this helps

[Shywawa]

Hi mancubus, attached.

Hi georgiboy, a string in a cell. I just want to make this validation and this was the idea I had before getting stuck.

CHECK Names.xlsm

Thank you!
Shywawa

[Paul_Hossler]

Updated after attachment posted


Assuming I understood ....

Capture.JPG

Option Explicit
 
Sub Match()
    Dim rCell As Range
     
    With ActiveSheet
        For Each rCell In Range(.Cells(2, 1), .Cells(2, 1).End(xlDown)).Cells
             'not case sensitive
            If InStr(1, rCell.Value, .Cells(rCell.Row, 7), vbTextCompare) > 0 And InStr(1, rCell.Value, .Cells(rCell.Row, 8), vbTextCompare) > 0 Then
                .Cells(rCell.Row, 2) = "OK"
            Else
                .Cells(rCell.Row, 2) = "Check"
            End If
       Next
    End With
End Sub

[Shywawa]

Hi Paul,

My code was producing similar hits if the names were on the same row. Unfortunately if you sort AtoZ or ZtoA in G or H the macro won't work anymore.
Sadly the file i am using has a lot more names in column G and H and it needs to work independently of the row where the values are. Attached a screenshot from the file you posted with a simple sort.

Capture2.jpg

Please advise.


Kind regards,
DD

[Paul_Hossler]

Column A has a variety of Last Name + First Name combinations written in all possible forms (John Deer; Deer, John; Deer John; Acapulco hotel Deer John)
Columns G and H are first Name Last Name of the people that are valid and which i need to do the validation for. needles to say these 2 need to be from the same row.

I misunderstood 'same row'

Anyways, it's easy enough

Option Explicit
 
Sub Match()
    Dim rCell As Range
    Dim aNames As Variant
    Dim r As Long
     
    With ActiveSheet
    
        aNames = .Cells(1, 7).CurrentRegion.Value
    
        For Each rCell In Range(.Cells(2, 1), .Cells(2, 1).End(xlDown)).Cells
            .Cells(rCell.Row, 2) = "Check"
             
             For r = LBound(aNames, 1) + 1 To UBound(aNames, 1)
                 'not case sensitive
                If InStr(1, rCell.Value, aNames(r, 1), vbTextCompare) > 0 And InStr(1, rCell.Value, aNames(r, 2), vbTextCompare) > 0 Then
                    .Cells(rCell.Row, 2) = "OK"
                    Exit For
                End If
            Next r
       Next
    End With
End Sub

However, since InStr is used, there is chance for error. A better solution will be more complicated


Capture.JPG

[georgiboy]

There is probably a much simpler way of doing this but thought i would post my best attempt:

Function removeSpecial(sInput As String) As String    Dim sSpecialChars As String
    Dim i As Long
    sSpecialChars = ",;"
    For i = 1 To Len(sSpecialChars)
        sInput = Replace$(sInput, Mid$(sSpecialChars, i, 1), "")
    Next
    removeSpecial = sInput
End Function


Sub SearchNames()
    Dim FstLstRng As Range, rCell As Range, CheckCells As Range
    Dim NameList As Variant, Nme As Variant
    Dim Str As String, a As Long, b As Long, c As Long

    Set FstLstRng = Range("G2:H" & Range("G" & Rows.Count).End(xlUp).Row).Cells
    Set CheckCells = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Cells
    
    NameList = FstLstRng
    
    For Each rCell In CheckCells.Cells
        rCell.Offset(, 1).Value = "CHECK"
        Str = removeSpecial(rCell.Value)
        Nme = Split(Str, " ")
        For a = 0 To UBound(Nme)
            For b = 1 To UBound(NameList)
                If UCase(Nme(a)) = UCase(NameList(b, 1)) Then
                    For c = 0 To UBound(Nme)
                        If UCase(Nme(c)) = UCase(NameList(b, 2)) Then
                            rCell.Offset(, 1).Value = "OK"
                            Exit For
                        End If
                    Next c
                End If
            Next b
        Next a
        For a = 0 To UBound(Nme)
            For b = 1 To UBound(NameList)
                If UCase(Nme(a)) = UCase(NameList(b, 2)) Then
                    For c = 0 To UBound(Nme)
                        If UCase(Nme(c)) = UCase(NameList(b, 1)) Then
                            rCell.Offset(, 1).Value = "OK"
                            Exit For
                        End If
                    Next c
                End If
            Next b
        Next a
    Next rCell
End Sub

May need to add some more special characters

Hope this helps

[Shywawa]

Hi Paul,

Thank you for the code. This will work, I am aware it might backfire on a few names but it should be ok. My next step will be to add the names that came from the OK check in the next column.
If you have any idea let me know. I will mark this thread as solved later on today.


Hi Georgiboy,

I ran your code also but it only gave Check from top to bottom.


Thank you both very much for the help on this one.


Kind regards,
Shywawa

[georgiboy]

How strange, here is the file i used to test:

CompName.xlsm

[Shywawa]

How strange, here is the file i used to test:

CompName.xlsm

This is working!

Thank you for the code! If you have any idea on how to put the matching names next to the validation (next column) please shoot!
I will crunch my brains on it today and if I can't find anything will open a new thread. Or should I keep this one open and update the name?

[georgiboy]

Maybe:

Function removeSpecial(sInput As String) As String    
    Dim sSpecialChars As String
    Dim i As Long
    sSpecialChars = ",;"
    For i = 1 To Len(sSpecialChars)
        sInput = Replace$(sInput, Mid$(sSpecialChars, i, 1), "")
    Next
    removeSpecial = sInput
End Function
 
Sub SearchNames()
    Dim FstLstRng As Range, rCell As Range, CheckCells As Range
    Dim NameList As Variant, Nme As Variant
    Dim Str As String, a As Long, b As Long, c As Long
     
    Set FstLstRng = Range("G2:H" & Range("G" & Rows.Count).End(xlUp).Row).Cells
    Set CheckCells = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Cells
    
    NameList = FstLstRng
     
    For Each rCell In CheckCells.Cells
        rCell.Offset(, 1).Value = "CHECK"
        Str = removeSpecial(rCell.Value)
        Nme = Split(Str, " ")
        For a = 0 To UBound(Nme)
            For b = 1 To UBound(NameList)
                If UCase(Nme(a)) = UCase(NameList(b, 1)) Then
                    For c = 0 To UBound(Nme)
                        If UCase(Nme(c)) = UCase(NameList(b, 2)) Then
                            rCell.Offset(, 1).Value = NameList(b, 1)
                            rCell.Offset(, 2).Value = NameList(b, 2)
                            Exit For
                        End If
                    Next c
                End If
            Next b
        Next a
        For a = 0 To UBound(Nme)
            For b = 1 To UBound(NameList)
                If UCase(Nme(a)) = UCase(NameList(b, 2)) Then
                    For c = 0 To UBound(Nme)
                        If UCase(Nme(c)) = UCase(NameList(b, 1)) Then
                            rCell.Offset(, 1).Value = NameList(b, 1)
                            rCell.Offset(, 2).Value = NameList(b, 2)
                            Exit For
                        End If
                    Next c
                End If
            Next b
        Next a
    Next rCell
End Sub

[Shywawa]

Perfect!



Thank you all for the help!