View Single Post
  #3   Report Post  
Posted to microsoft.public.excel.programming
[email protected] ivanov.ivaylo@gmail.com is offline
external usenet poster
 
Posts: 8
Default How to replace a tilde with the corresponding headword

Hi Tom,

Your solution works (a bit slower but works!). It retains the bold and
red color font but the italic formatting was removed. Can this be
corrected?


Tom Ogilvy написа:
This is pretty slow, but does what you want. It shows what cell it is
working on in the status bar at the bottom left. The last processed cell
should be in the upper left corner of the screen.

Sub changeTilde()
Dim v1(), v2() As Boolean
Dim v1a(), v2a() As Boolean
Dim v3() As String, v3a() As String
Dim v4() As Long, v4a() As Long
Dim i As Long, j As Long
Dim k As Long, l As Long
Dim cnt As Long, cnt1 As Long
Dim cell As Range, rng As Range
Dim cell1 As Range, sStr As String
Set rng = Range(Cells(1, 1), _
Cells(Rows.Count, 1).End(xlUp))

Application.ScreenUpdating = False
For Each cell In rng
Application.StatusBar = cell.Address

Set cell1 = cell.Offset(0, 1)
If InStr(1, cell1.Value, "~", vbTextCompare) Then
Application.Goto cell, True
' cell.Interior.ColorIndex = 6
cnt = Len(cell1.Value)

ReDim v1(1 To cnt)
ReDim v2(1 To cnt)
ReDim v3(1 To cnt)
ReDim v4(1 To cnt)
For i = 1 To cnt
v1(i) = cell1 _
.Characters(i, 1).Text
v2(i) = cell1 _
.Characters(i, 1).Font.Bold
v3(i) = cell1 _
.Characters(i, 1).Font.Name
v4(i) = cell1 _
.Characters(i, 1).Font.ColorIndex

Next i

j = 0
For i = 1 To cnt
If v1(i) = "~" Then
cnt1 = cnt1 + Len(cell)
Else
cnt1 = cnt1 + 1
End If
Next i
ReDim v1a(1 To cnt1)
ReDim v2a(1 To cnt1)
ReDim v3a(1 To cnt1)
ReDim v4a(1 To cnt1)
j = 1
For i = 1 To cnt
If v1(i) = "~" Then
For k = 1 To Len(cell)
v1a(j) = cell.Characters(k, 1).Text
v2a(j) = v2(i)
v3a(j) = v3(i)
v4a(j) = v4(i)
j = j + 1
Next k
Else
v1a(j) = v1(i)
v2a(j) = v2(i)
v3a(j) = v3(i)
v4a(j) = v4(i)
j = j + 1
End If
Next i
sStr = ""
For l = 1 To cnt1
sStr = sStr & v1a(l)
Next l
cell1.Value = sStr
For l = 1 To cnt1
cell1.Characters(l, 1).Font.Bold = v2a(l)
cell1.Characters(l, 1).Font.Name = v3a(l)
cell1.Characters(l, 1).Font.ColorIndex = v4a(l)
Next l
Application.ScreenUpdating = True
Application.ScreenUpdating = False
End If
Next cell
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub

--
Regards,
Tom Ogilvy


" wrote:

Thank you all! That's what I need.

However your macro distorts all the formatting in colum B.

I tested both macros on this file:
http://rapidshare.com/files/9898670/Before.xls.html
and ended up with this:
http://rapidshare.com/files/9899030/After.xls.html

Can the macro be amended to preserve the original formatting?

Thanks again!