CODEWITHSUNDEEP
excelvbasearch
jrdidigetthis
jrdidigetthis

Reputation: 21

Excel VBA to search for text in a cell, if located, put text into another cell

I have a simple worksheet with 4 main columns: Date, Item, Amount, Client.

Item column is populated from a system that gives junk text with a specific word in the middle. Example: "00x1500s544v Client1 1158ec5". Let's just say I can't get clean data.

I have a list of 20+ clients. I would like to VB to search for the client name from the list of 20+ in the Item cell and if located, return the name of the client in another column called Client. The client list is in another tab called "Client". Let's call this tab "Records". Sometimes there isn't a client name in the Item cell, in this case, we enter "Not a Client" in the Client cell.

Our workflow is to copy and paste data from one file (emailed to us) into this file. So copy A-D from source email file and paste into destination file at the bottom of the running list. After copy/paste, we would like the code to review the new records (or all records if it's easier) and update the Client column with the Client name.

Thanks

I found this code on StackOverFlow and it works, but only if there is an exact match. It won't search inside a text string.

using a test worksheet

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("b:b")) Is Nothing Then
FillConversion
End If
End Sub

Sub FillConversion()

Const FirstRow = 3
Const SourceCol = "B"
Const TargetCol = "G"

Dim CurRow As Long
Dim LastRow As Long

Application.ScreenUpdating = False
LastRow = Range(SourceCol & Rows.Count).End(xlUp).Row

For CurRow = FirstRow To LastRow
    Select Case Cells(CurRow, SourceCol).Value
        
        Case "Client1"
        Cells(CurRow, TargetCol).Value = "Client1"
        
        'add the other client cases here...

    End Select
Next CurRow

Application.ScreenUpdating = True

End Sub

Upvotes: 0

Views: 52

Answers (1)

taller
taller

Reputation: 18943

Assuming the client name is a single word without spaces, the Change event script processes the input data (pasted values).

Pls try

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r As Range: Set r = Intersect(Target, Me.Range("B:B"))
    If Not r Is Nothing Then
        Application.EnableEvents = False
        Dim arrList ' load Client list
        arrList = Sheets("Client").Range("A1").CurrentRegion.Value
        Dim arrB: ' load input
        arrB = IIf(r.Count = 1, Array(r.Value), Application.Transpose(r.Value))
        Dim arrG: arrG = arrB
        Dim i As Long, j As Long
        For i = LBound(arrB) To UBound(arrB)
            If Len(Trim(arrB(i))) = 0 Then
                arrG(i) = ""
            Else
                arrG(i) = "Not a Client"
                For j = LBound(arrList) + 1 To UBound(arrList) ' remove +1 if there isn't header row in client list table
                    If InStr(1, Chr(32) & arrB(i) & Chr(32), _
                        Chr(32) & arrList(j, 1) & Chr(32), vbTextCompare) > 0 Then
                        arrG(i) = arrList(j, 1)
                        Exit For
                    End If
                Next j
            End If
        Next i
        ' populate Col G
        r.Offset(0, 5).Value = Application.Transpose(arrG)
        Application.EnableEvents = True
    End If
End Sub

Input1~4 represents Date, Item, Amount, and Client respectively. The gray area on the sheet represents the pasted data.

enter image description here

Upvotes: 0

Related Questions