Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Find & Replace : Keep the original format
I am trying use replace in a worksheet through the below code.
Cells.Replace What:="ABC", Replacement:="DEF", LookAt:=xlPart, SearchOrder :=xlByRows, MatchCase:=False, SearchFormat:=True, ReplaceFormat:=True The problem is that when replace is done the formatting of the cell becomes same as of the first character. example if I have text in a cell with following formatting (Part 1 - Black regular) (Part 2 - Red Italics) (Part 3 - Black Regular) when i do replace it changes the whole cell to black regular. Is there a way to do replace with keeping the original formatting. -- Ajit |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Find & Replace : Keep the original format
I think you'd have to keep track of each character's font attributes.
This works very slowly, but works: Option Explicit Option Compare Text Type myCharacter myChar As String myLen As Long myName As String myFontStyle As String mySize As Double myStrikethrough As Boolean mySuperscript As Boolean mySubscript As Boolean myOutlineFont As Boolean myShadow As Boolean myUnderline As Long myColorIndex As Long End Type Sub testme() Application.ScreenUpdating = False Dim myWords As Variant Dim myNewWords As Variant Dim myRng As Range Dim foundCell As Range Dim iCtr As Long 'word counter Dim lCtr As Long 'length of string counter Dim cCtr As Long 'character counter Dim usedChars As Long Dim FirstAddress As String Dim AllFoundCells As Range Dim myCell As Range Dim myStr As String Dim myCharacters() As myCharacter myWords = Array("xxx", "yy") myNewWords = Array("qqqq", "BBBB") Set myRng = Selection On Error Resume Next Set myRng = Intersect(myRng, _ myRng.Cells.SpecialCells(xlCellTypeConstants, xlTextValues)) On Error GoTo 0 If myRng Is Nothing Then MsgBox "Please choose a range that contains text constants!" Exit Sub End If For iCtr = LBound(myWords) To UBound(myWords) FirstAddress = "" Set foundCell = Nothing With myRng Set foundCell = .Find(what:=myWords(iCtr), _ LookIn:=xlValues, lookat:=xlPart, _ after:=.Cells(.Cells.Count)) If foundCell Is Nothing Then MsgBox myWords(iCtr) & " wasn't found!" Else Set AllFoundCells = foundCell FirstAddress = foundCell.Address Do If AllFoundCells Is Nothing Then Set AllFoundCells = foundCell Else Set AllFoundCells = Union(foundCell, AllFoundCells) End If Set foundCell = .FindNext(foundCell) Loop While Not foundCell Is Nothing _ And foundCell.Address < FirstAddress End If End With If AllFoundCells Is Nothing Then 'do nothing Else For Each myCell In AllFoundCells.Cells ReDim myCharacters(1 To Len(myCell.Value)) usedChars = 0 cCtr = 1 lCtr = 0 Do usedChars = usedChars + 1 With myCell.Characters(cCtr, 1) myCharacters(usedChars).myName = .Font.Name myCharacters(usedChars).myFontStyle = .Font.FontStyle myCharacters(usedChars).mySize = .Font.Size myCharacters(usedChars).myStrikethrough _ = .Font.Strikethrough myCharacters(usedChars).mySuperscript _ = .Font.Superscript myCharacters(usedChars).mySubscript = .Font.Subscript myCharacters(usedChars).myOutlineFont _ = .Font.OutlineFont myCharacters(usedChars).myShadow = .Font.Shadow myCharacters(usedChars).myUnderline = .Font.Underline myCharacters(usedChars).myColorIndex = .Font.ColorIndex If Mid(myCell.Value, cCtr, Len(myWords(iCtr))) _ = myWords(iCtr) Then myCharacters(usedChars).myChar = myNewWords(iCtr) myCharacters(usedChars).myLen = Len(myNewWords(iCtr)) cCtr = cCtr + Len(myWords(iCtr)) lCtr = lCtr + Len(myNewWords(iCtr)) Else myCharacters(usedChars).myChar _ = Mid(myCell.Value, cCtr, 1) myCharacters(usedChars).myLen = 1 cCtr = cCtr + 1 lCtr = lCtr + 1 End If If cCtr Len(myCell.Value) Then Exit Do End With Loop myStr = Space(lCtr) lCtr = 1 For cCtr = 1 To usedChars Mid(myStr, lCtr, myCharacters(cCtr).myLen) _ = myCharacters(cCtr).myChar lCtr = lCtr + myCharacters(cCtr).myLen Next cCtr myCell.Value = myStr cCtr = 1 lCtr = 1 Do With myCell.Characters(lCtr, myCharacters(cCtr).myLen) .Font.Name = myCharacters(cCtr).myName .Font.FontStyle = myCharacters(cCtr).myFontStyle .Font.Size = myCharacters(cCtr).mySize .Font.Strikethrough _ = myCharacters(cCtr).myStrikethrough .Font.Superscript = myCharacters(cCtr).mySuperscript .Font.Subscript = myCharacters(cCtr).mySubscript .Font.OutlineFont = myCharacters(cCtr).myOutlineFont .Font.Shadow = myCharacters(cCtr).myShadow .Font.Underline = myCharacters(cCtr).myUnderline .Font.ColorIndex = myCharacters(cCtr).myColorIndex End With lCtr = lCtr + myCharacters(cCtr).myLen cCtr = cCtr + 1 If lCtr Len(myStr) Then Exit Do End If Loop Next myCell End If Next iCtr Application.ScreenUpdating = True End Sub The new word actually takes the attributes of the first letter in the old word. (I wasn't sure how to handle this if the number of letters in the replacement word was different than the number of letters in the original word. DEF replaced with EFGHIJK Ajit wrote: I am trying use replace in a worksheet through the below code. Cells.Replace What:="ABC", Replacement:="DEF", LookAt:=xlPart, SearchOrder :=xlByRows, MatchCase:=False, SearchFormat:=True, ReplaceFormat:=True The problem is that when replace is done the formatting of the cell becomes same as of the first character. example if I have text in a cell with following formatting (Part 1 - Black regular) (Part 2 - Red Italics) (Part 3 - Black Regular) when i do replace it changes the whole cell to black regular. Is there a way to do replace with keeping the original formatting. -- Ajit -- Dave Peterson |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Find & Replace : Keep the original format
with wordwrap fixed:
I think you'd have to keep track of each character's font attributes. This works very slowly, but works: Option Explicit Option Compare Text Type myCharacter myChar As String myLen As Long myName As String myFontStyle As String mySize As Double myStrikethrough As Boolean mySuperscript As Boolean mySubscript As Boolean myOutlineFont As Boolean myShadow As Boolean myUnderline As Long myColorIndex As Long End Type Sub testme() Application.ScreenUpdating = False Dim myWords As Variant Dim myNewWords As Variant Dim myRng As Range Dim foundCell As Range Dim iCtr As Long 'word counter Dim lCtr As Long 'length of string counter Dim cCtr As Long 'character counter Dim usedChars As Long Dim FirstAddress As String Dim AllFoundCells As Range Dim myCell As Range Dim myStr As String Dim myCharacters() As myCharacter myWords = Array("xxx", "yy") myNewWords = Array("qqqq", "BBBB") Set myRng = Selection On Error Resume Next Set myRng = Intersect(myRng, _ myRng.Cells.SpecialCells(xlCellTypeConstants, xlTextValues)) On Error GoTo 0 If myRng Is Nothing Then MsgBox "Please choose a range that contains text constants!" Exit Sub End If For iCtr = LBound(myWords) To UBound(myWords) FirstAddress = "" Set foundCell = Nothing With myRng Set foundCell = .Find(what:=myWords(iCtr), _ LookIn:=xlValues, lookat:=xlPart, _ after:=.Cells(.Cells.Count)) If foundCell Is Nothing Then MsgBox myWords(iCtr) & " wasn't found!" Else Set AllFoundCells = foundCell FirstAddress = foundCell.Address Do If AllFoundCells Is Nothing Then Set AllFoundCells = foundCell Else Set AllFoundCells = Union(foundCell, AllFoundCells) End If Set foundCell = .FindNext(foundCell) Loop While Not foundCell Is Nothing _ And foundCell.Address < FirstAddress End If End With If AllFoundCells Is Nothing Then 'do nothing Else For Each myCell In AllFoundCells.Cells ReDim myCharacters(1 To Len(myCell.Value)) usedChars = 0 cCtr = 1 lCtr = 0 Do usedChars = usedChars + 1 With myCell.Characters(cCtr, 1) myCharacters(usedChars).myName = .Font.Name myCharacters(usedChars).myFontStyle = .Font.FontStyle myCharacters(usedChars).mySize = .Font.Size myCharacters(usedChars).myStrikethrough _ = .Font.Strikethrough myCharacters(usedChars).mySuperscript _ = .Font.Superscript myCharacters(usedChars).mySubscript = .Font.Subscript myCharacters(usedChars).myOutlineFont _ = .Font.OutlineFont myCharacters(usedChars).myShadow = .Font.Shadow myCharacters(usedChars).myUnderline = .Font.Underline myCharacters(usedChars).myColorIndex = .Font.ColorIndex If Mid(myCell.Value, cCtr, Len(myWords(iCtr))) _ = myWords(iCtr) Then myCharacters(usedChars).myChar = myNewWords(iCtr) myCharacters(usedChars).myLen _ = Len(myNewWords(iCtr)) cCtr = cCtr + Len(myWords(iCtr)) lCtr = lCtr + Len(myNewWords(iCtr)) Else myCharacters(usedChars).myChar _ = Mid(myCell.Value, cCtr, 1) myCharacters(usedChars).myLen = 1 cCtr = cCtr + 1 lCtr = lCtr + 1 End If If cCtr Len(myCell.Value) Then Exit Do End With Loop myStr = Space(lCtr) lCtr = 1 For cCtr = 1 To usedChars Mid(myStr, lCtr, myCharacters(cCtr).myLen) _ = myCharacters(cCtr).myChar lCtr = lCtr + myCharacters(cCtr).myLen Next cCtr myCell.Value = myStr cCtr = 1 lCtr = 1 Do With myCell.Characters(lCtr, myCharacters(cCtr).myLen) .Font.Name = myCharacters(cCtr).myName .Font.FontStyle = myCharacters(cCtr).myFontStyle .Font.Size = myCharacters(cCtr).mySize .Font.Strikethrough _ = myCharacters(cCtr).myStrikethrough .Font.Superscript = myCharacters(cCtr).mySuperscript .Font.Subscript = myCharacters(cCtr).mySubscript .Font.OutlineFont = myCharacters(cCtr).myOutlineFont .Font.Shadow = myCharacters(cCtr).myShadow .Font.Underline = myCharacters(cCtr).myUnderline .Font.ColorIndex = myCharacters(cCtr).myColorIndex End With lCtr = lCtr + myCharacters(cCtr).myLen cCtr = cCtr + 1 If lCtr Len(myStr) Then Exit Do End If Loop Next myCell End If Next iCtr Application.ScreenUpdating = True End Sub The new word actually takes the attributes of the first letter in the old word. (I wasn't sure how to handle this if the number of letters in the replacement word was different than the number of letters in the original word. DEF replaced with EFGHIJK Ajit wrote: I am trying use replace in a worksheet through the below code. Cells.Replace What:="ABC", Replacement:="DEF", LookAt:=xlPart, SearchOrder :=xlByRows, MatchCase:=False, SearchFormat:=True, ReplaceFormat:=True The problem is that when replace is done the formatting of the cell becomes same as of the first character. example if I have text in a cell with following formatting (Part 1 - Black regular) (Part 2 - Red Italics) (Part 3 - Black Regular) when i do replace it changes the whole cell to black regular. Is there a way to do replace with keeping the original formatting. -- Ajit -- Dave Peterson |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
"Find" a wildcard as a place marker and "replace" with original va | Excel Discussion (Misc queries) | |||
Find/Replace changes cell format ?????? | Excel Discussion (Misc queries) | |||
find and replace for date format | Excel Discussion (Misc queries) | |||
Find & Replace text format | Excel Discussion (Misc queries) | |||
find replace format | Excel Discussion (Misc queries) |