Find and Replace help

[iliveinca]

I got this VBA from the link below, it finds and replaces whole cell, can someone make change to it to replace partial in a cell?


-----------Code----------------------


Sub OpenUltraReplace()
' Opens UltraReplace.xls
ChDir "C:\Documents and Settings\myFolder"
Workbooks.Open Filename:= _
"C:\Documents and Settings\myFolder\UltraReplace.xls"
ActiveWindow.ActivateNext
End Sub

Sub ChgA()
' TommyBak developed this on mrexcel.com
' requires MS Scripting Runtime (In VBE Window Tools > Reference)
' this code is actually in the UltraReplace.xls file already
Dim dctCompany As New Dictionary
Dim rgReplace As Range
Dim vaReplace As Variant
Dim C As Range, x As Long, LastRow As Long
Dim IndexCol As Range

Set IndexCol = Application.InputBox(prompt:="Point out the header in the column for replacement", Type:=8)
LastRow = Cells(65536, IndexCol.Column).End(xlUp).Row
Set rgReplace = Range(IndexCol.Offset(1, 0), Cells(LastRow, IndexCol.Column))

With ThisWorkbook.Sheets("ChgA")
For Each C In .Range("A2:A" & .Range("A65536").End(xlUp).Row)
dctCompany.Add Key:=CStr(C.Value), Item:=CStr(C.Offset(0, 1).Value)
Next
End With

vaReplace = rgReplace

For x = 1 To UBound(vaReplace, 1)
If dctCompany.Exists(vaReplace(x, 1)) = True Then vaReplace(x, 1) = dctCompany.Item(vaReplace(x, 1))
Next

rgReplace = vaReplace

Set dctCompany = Nothing
Set rgReplace = Nothing
Set vaReplace = Nothing
End Sub

[mdmackillop]

Welcome to VBAX
Can you explain exactly what you wish to achieve?

[iliveinca]

Workbook Dict.xls (contain below VBA code)
Sheet ChaA
Column A contain old data
Column B contain new data
In a any workbook that contains your data, run ChgA will be replace every cell that match A (entire cell match) to B.
I want to replace partial match in a cell rather than entire cell, please help.


Sub ChgA()
' requires MS Scripting Runtime (In VBE Window Tools > Reference)
Dim dctCompany As New Dictionary
Dim rgReplace As Range
Dim vaReplace As Variant
Dim C As Range, x As Long, LastRow As Long
Dim IndexCol As Range
Set IndexCol = Application.InputBox(prompt:="Point out the header in the column for replacement", Type:=8)
LastRow = Cells(65536, IndexCol.Column).End(xlUp).Row
Set rgReplace = Range(IndexCol.Offset(1, 0), Cells(LastRow, IndexCol.Column))
With ThisWorkbook.Sheets("ChgA")
For Each C In .Range("A2:A" & .Range("A65536").End(xlUp).Row)
dctCompany.Add Key:=CStr(C.Value), Item:=CStr(C.Offset(0, 1).Value)
Next
End With
vaReplace = rgReplace
For x = 1 To UBound(vaReplace, 1)
If dctCompany.Exists(vaReplace(x, 1)) = True Then vaReplace(x, 1) = dctCompany.Item(vaReplace(x, 1))
Next
rgReplace = vaReplace
Set dctCompany = Nothing
Set rgReplace = Nothing
Set vaReplace = Nothing
End Sub

[iliveinca]

Please give me some idea!

[mdmackillop]

If I understand you correctly, try this. The Check lines can be deleted if the code is working correctly

Option Explicit
Sub DoReplace()
Dim wsSource As Worksheet
Dim wsTgt As Worksheet
Dim rSource As Range
Dim rTgt As Range
Dim c As Range
Dim cel As Range
Set wsSource = ThisWorkbook.Sheets(1)
Set wsTgt = Workbooks("SampleReplace.xls").Sheets(1)
Set rSource = Range(wsSource.Cells(2, 1), wsSource.Cells(Rows.Count, 1).End(xlUp))
Set rTgt = Range(wsTgt.Cells(2, 1), wsTgt.Cells(Rows.Count, 1).End(xlUp))
For Each cel In rTgt
Set c = rSource.Find(cel, , , xlPart)
If Not c Is Nothing And cel <> c Then
cel.Offset(, 1) = cel 'Check
cel.Value = c.Offset(, 1).Value
cel.Interior.ColorIndex = 6 'Check
End If
Next
End Sub