PDA

View Full Version : Mass Find and Replace VBA - Need Help



ajilejay
09-18-2016, 02:55 PM
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
09-18-2016, 04:18 PM
What is arrKeysB?

ajilejay
09-18-2016, 04:37 PM
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
09-18-2016, 04:57 PM
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
09-18-2016, 05:26 PM
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
09-18-2016, 05:27 PM
?


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
09-18-2016, 06:12 PM
Sorry :(. The last one isn't working for me at all.

What information can I provide to make this easier?

mana
09-18-2016, 06:30 PM
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
09-18-2016, 07:10 PM
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
09-18-2016, 07:15 PM
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
09-18-2016, 07:47 PM
YES YOU DID IT!!!!! THANK YOU SO MUCH!

mana
09-18-2016, 07:57 PM
> 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
09-18-2016, 08:10 PM
....Actually for some reason it seems to be producing duplicates?

ajilejay
09-18-2016, 08:12 PM
PERFECT! BRAVO!