iliveinca
12-07-2011, 02:03 AM
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
-----------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