Mass Find and Replace VBA - Need Help

[ajilejay]

Sub MatchAndReplace()
    Dim ws As Worksheet
    Dim arrKeysA As Variant, arrKeysB As Variant, arrData As Variant
    Dim i As Integer, j As Integer, k As Integer

    '-- here we take keys column A from Sheet 1 into a 1D array
    arrKeysA = WorksheetFunction.Transpose(Sheets(1).Range("A1:A38").Value)
    '-- here we take to be replaced range from Sheet 2 into a 2D array
    arrData = WorksheetFunction.Transpose(Sheets(2).Range("A1:I100").Value)

    '-- here we iterate through each key in keys array searching it in
    '-- to-be-replaced array
    For i = LBound(arrKeysA) To UBound(arrKeysA)
        For j = LBound(arrData, 2) To UBound(arrData, 2)
                '-- when there's a match we replace that element
                If UCase(Trim(arrData(1, j))) = UCase(Trim(arrKeysA(i))) Then
                    arrData(1, j) = Trim(arrKeysB(i))
                End If
                '-- when there's a match we replace that element
                If UCase(Trim(arrData(2, j))) = UCase(Trim(arrKeysA(i))) Then
                    arrData(2, j) = Trim(arrKeysB(i))
                End If
        Next j
    Next i

    '-- put new data on the sheet 3
    Sheets(3).Range("A1").Offset(0, 0).Resize(UBound(arrData, 2), _
    UBound(arrData)) = Application.Transpose(arrData)

End Sub

What this does. Compare sheet 1 to sheet 2 and transpose matches to sheet 3.

What I would like to have happen. Compare sheet 2 to sheet 1 and replace matches in sheet 1 with sheet 2 (case sensitive) as the index.
For example

Sheet 1 ESCITALOPRAM OXALATE 20 MG PO TABS

FAMOTIDINE 20 MG PO TABS

FERROUS SULFATE 325 (65 FE) MG PO TABS

FINASTERIDE 5 MG PO TABS

FISH OIL 1000 MG PO CAPS

FLUOXETINE HCL 20 MG PO CAPS

FOLIC ACID 1 MG PO TABS

FUROSEMIDE 20 MG PO TABS

FUROSEMIDE 40 MG PO TABS

FUROSEMIDE 80 MG PO TABS

GABAPENTIN 100 MG PO CAPS Sheet 2 DULoxetine ePHEDrine EPINEPHrine fentaNYL flavoxATE FLUoxetine fluPHENAZine fluvoxaMINE guaiFENesin guanFACINE HumaLOG* Result for Sheet 1(note:the only match being Fluoxetine) ESCITALOPRAM OXALATE 20 MG PO TABS FAMOTIDINE 20 MG PO TABS FERROUS SULFATE 325 (65 FE) MG PO TABS FINASTERIDE 5 MG PO TABS FISH OIL 1000 MG PO CAPS FLUoxetine HCL 20 MG PO CAPS FOLIC ACID 1 MG PO TABS FUROSEMIDE 20 MG PO TABS FUROSEMIDE 40 MG PO TABS FUROSEMIDE 80 MG PO TABS GABAPENTIN 100 MG PO CAPS

How do I fix this ?

[mana]

What is arrKeysB?

[ajilejay]

Sub MatchAndReplace()
    Dim ws As Worksheet
    Dim arrKeysA As Variant, arrKeysB As Variant, arrData As Variant
    Dim i As Integer, j As Integer, k As Integer
    '-- here we take keys column A from Sheet 1 into a 1D array
    arrKeysA = WorksheetFunction.Transpose(Sheets(1).Range("A1:A38").Value)
    '-- here we take keys column B from Sheet 1 into a 1D array
    arrKeysB = WorksheetFunction.Transpose(Sheets(1).Range("B1:B38").Value)
    '-- here we take to be replaced range from Sheet 2 into a 2D array
    arrData = WorksheetFunction.Transpose(Sheets(2).Range("A1:I100").Value)
    '-- here we iterate through each key in keys array searching it in
    '-- to-be-replaced array
    For i = LBound(arrKeysA) To UBound(arrKeysA)
        For j = LBound(arrData, 2) To UBound(arrData, 2)
                '-- when there's a match we replace that element
                If UCase(Trim(arrData(1, j))) = UCase(Trim(arrKeysA(i))) Then
                    arrData(1, j) = Trim(arrKeysB(i))
                End If
                '-- when there's a match we replace that element
                If UCase(Trim(arrData(2, j))) = UCase(Trim(arrKeysA(i))) Then
                    arrData(2, j) = Trim(arrKeysB(i))
                End If
        Next j
    Next i
    '-- put new data on the sheet 3
    Sheets(3).Range("A1").Offset(0, 0).Resize(UBound(arrData, 2), _
    UBound(arrData)) = Application.Transpose(arrData)
End Sub

My apologies

[mana]

Option Explicit

Sub test()
    Dim dic As Object
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim c As Range
    Dim s As String
    
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    Set ws3 = Worksheets("Sheet3")
    
    Set dic = CreateObject("Scripting.dictionary")
    
    For Each c In ws1.Range("a1", ws1.Range("A" & Rows.Count).End(xlUp))
        s = Split(c.Value)(0)
        dic(s) = c.Value
    Next
    
    For Each c In ws2.Range("a1", ws2.Range("A" & Rows.Count).End(xlUp))
        s = UCase(c.Value)
        If dic.exists(s) Then
            dic(s) = Replace(dic(s), s, c.Value)
        End If
    Next
    
    ws3.UsedRange.ClearContents
    ws3.Range("a1").Resize(dic.Count).Value = _
        WorksheetFunction.Transpose(dic.items)


End Sub

[ajilejay]

Than you so much!!!
This is almost perfect the only thing is that I want it to replace the word in the original string instead of splitting it out to a 3rd sheet if that is possible.

Thanks

[mana]

?

Option Explicit

Sub test2()
    Dim v
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim c As Range
  
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    
    v = ws1.Range("a1").CurrentRegion.Value


    For Each c In ws2.Range("a1", ws2.Range("A" & Rows.Count).End(xlUp))
        v = Application.Substitute(v, c.Offset(, 1).Value, c.Value)
    Next
    
    ws1.Range("a1").Resize(UBound(v, 1), UBound(v, 2)).Value = v
    
End Sub

[ajilejay]

Sorry . The last one isn't working for me at all.

What information can I provide to make this easier?

[mana]

I can not understand your sheets.


Before:
Sheet1 layout
　　　-A-
1 ESCITALOPRAM OXALATE 20 MG PO TABS
2 FLUOXETINE HCL 20 MG PO CAP
3


Sheet2 layout
　　　-A-　　　　　　　-B-
1 fluPHENAZine　　　FLUPHENAZINE
2 FLUoxetine　　　　 FLUOXETINE
3 fentaNYL 　　　　　FENTANYL




After:
Sheet1 layout
　　　-A-
1 ESCITALOPRAM OXALATE 20 MG PO TABS
2 FLUoxetine HCL 20 MG PO CAPS

[mana]

i can not understand yet.
but please try

Option Explicit

Sub test3()
    Dim dic As Object
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim c As Range
    Dim s As String
    
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    
    Set dic = CreateObject("Scripting.dictionary")
    
    For Each c In ws1.Range("a1", ws1.Range("A" & Rows.Count).End(xlUp))
        s = Split(c.Value)(0)
        dic(s) = c.Value
    Next
    
    For Each c In ws2.Range("a1", ws2.Range("A" & Rows.Count).End(xlUp))
        s = UCase(c.Value)
        If dic.exists(s) Then
            dic(s) = Replace(dic(s), s, c.Value)
        End If
    Next
    
    ws1.Range("a1").Resize(dic.Count).Value = _
        WorksheetFunction.Transpose(dic.items)


End Sub

[ajilejay]

It is more like

Sheet 1
Column A

DULOXETINE HCL 30 MG CPEP

DULOXETINE HCL 60 MG CPEP

ESCITALOPRAM OXALATE 20 MG TABS

FAMOTIDINE 20 MG TABS

FERROUS SULFATE 325 (65 FE) MG TABS

FINASTERIDE 5 MG TABS

FISH OIL 1000 MG CAPS

FLUOXETINE HCL 20 MG CAPS

FOLIC ACID 1 MG TABS

Sheet 2
Column A

DULoxetine

ePHEDrine

EPINEPHrine

fentaNYL

flavoxATE

FLUoxetine

fluPHENAZine

fluvoxaMINE

guaiFENesin

guanFACINE

Humalog*

So what I would like it to do is search for sheet 1 for matches from sheet 2.
When a match is found I would like it to replace the match with the case format in sheet 2.
So sheet 1 would then result in
Sheet 1 Result
Column A

DULoxetine HCL 30 MG CPEP

DULoxetine HCL 60 MG CPEP

ESCITALOPRAM OXALATE 20 MG TABS

FAMOTIDINE 20 MG TABS

FERROUS SULFATE 325 (65 FE) MG TABS

FINASTERIDE 5 MG TABS

FISH OIL 1000 MG CAPS

FLUoxetine HCL 20 MG CAPS

FOLIC ACID 1 MG TABS Thanks for your help

[ajilejay]

YES YOU DID IT!!!!! THANK YOU SO MUCH!

[mana]

> Humalog*

means wild carrd ?

Option Explicit

Sub test4()
    Dim v
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim c As Range
    Dim s As String
  
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    
    v = ws1.Range("a1").CurrentRegion.Columns(1).Value


    For Each c In ws2.Range("a1", ws2.Range("A" & Rows.Count).End(xlUp))
        s = c.Value
        If Right(s, 1) = "*" Then s = Left(s, Len(s) - 1)
        v = Application.Substitute(v, UCase(s), s)
    Next
    
    ws1.Range("a1").Resize(UBound(v, 1), UBound(v, 2)).Value = v
    
End Sub

[ajilejay]

....Actually for some reason it seems to be producing duplicates?

[ajilejay]

PERFECT! BRAVO!