View Single Post
  #10   Report Post  
Posted to microsoft.public.excel.programming
Shetty Shetty is offline
external usenet poster
 
Posts: 78
Default Cherecters and fonts in part of cell

Cheeeeeeeeeeeears Dave.
This modification works like a charm......
Many many thanks Dave.
I was struggling from last 15 days to acheive this but failed in the
last stage.

Bob,
Thanks to you also. Actually that time the code was changing any
cherecter irrespective to its position. The reason I said vague is coz
I could not establish any pattern or logic for wrong replacements.
Thanks again to spend your time for solving my puzzle.

I WITH BOTH OF YOU AND THE NG LISTERS A VERY VERY HAPPY AND PROSPOROUS
NEW YEAR.
WITH A HOPE THAT TSUNAMI DOES NOT COME AGAIN.

Regards,
Shetty.

Dave Peterson wrote:
This modification of my modification of Bob's original code seemed to

work ok:

Option Explicit
Sub JI2()
Dim pos As Long
Dim CELL As Range
Dim myPositions() As Long
Dim pCtr As Long
Dim FoundOne As Boolean

For Each CELL In Selection
FoundOne = False
pCtr = 0
Do
pos = InStr(1, CELL.Value, "HL", vbBinaryCompare)
If pos = 0 Then
Exit Do
End If
FoundOne = True

pCtr = pCtr + 1
ReDim Preserve myPositions(1 To pCtr)
myPositions(pCtr) = pos
CELL.Value = Left(CELL.Value, pos - 1) & "P" _
& Right(CELL.Value, Len(CELL.Value) - pos

- 1)
Loop

If FoundOne = True Then
For pCtr = LBound(myPositions) To UBound(myPositions)
CELL.Characters(myPositions(pCtr), 1).Font.Name =

"Wingdings 2"
Next pCtr
End If
Next CELL

End Sub

Shetty wrote:

Thanks to both of you.
Yes Bob. There may be multiple occurances as well as nil

occurances. I
tried your code with do loop but it does not work, gives very vague
results. I don't know why it works that way with do loop.

Dave - I have added one If Not IsEmpty(CELL) Then statement to skip
blank cells.
Your code works fine as long as there is atleast one occurance.
If the cell does not contain HL then 1st part to replace is skipped

by
If pos = 0 Then
Exit Do
End If
But, 2nd part is still executed. Its a for loop.
For pCtr = LBound(myPositions) To UBound(myPositions)
CELL.Characters(myPositions(pCtr), 1).Font.NAME = "wingding 2"
CELL.Characters(myPositions(pCtr), 1).Font.Bold = True
Next pCtr

There are two things.
1. If 1st cell is with nil occurance, then code breaks on error
highlighting above for loop (subscript out of range).
2. If If any subsequent cell is with nil occurance, then above for

loop
changes the font of any other cherecter making it unreadable.

I tried to bypass this for loop with a goto statement.
If pos =0 then goto ncell
...code
ncell:
next cell
end sub
With this, cells with nil occurance are not changed but the

replacement
made in cells containing HL are not applied new font.

I hope, this also can be solved or a workaround is possible.
Regards,
Shetty.


--

Dave Peterson