Replace a tilde with the corresponding headword

[quanto]

Greetings to all,

I'm facing the following problem.

I have a dictionary database in Excel. The headwords are in column A, the dictionary entry is in column B. The dictionary entries, however, contain examples in which the headword is substituted by a tilde sign.

All I try to do is to replace the tilde with the corresponding headword.

For example:

Column A: steel
Column B: 1. 1) а) сталь strip of ~ ? лист стали; to make, produce ~ ? лить, производить сталь; to temper ~ ? закалять сталь; bar ~ ? брусковая сталь; ingot ~ ? литая сталь; sheet ~, slab ~ ? листовая сталь; stainless ~ ? нержавеющая сталь; б) стальная пластинка; 2) твердость; 3) холодное оружие; меч, шпага

I need to achieve this:

Column A: steel
Column B: 1. 1) а) сталь strip of steel ? лист стали; to make, produce steel ? лить, производить сталь; to temper steel ? закалять сталь; bar steel ? брусковая сталь; ingot steel ? литая сталь; sheet steel, slab steel ? листовая сталь; stainless steel ? нержавеющая сталь; б) стальная пластинка; 2) твердость; 3) холодное оружие; меч, шпага

All instances of the tilde sign are replaced with the headword ("steel" in this case).

Can you help me to do this with an Excel macro? I use Excel 2003. Thank you!

Note: Some headwords consist of more than one word.

[Bob Phillips]

[vba]

Public Sub ProcessData()
Dim i As Long
Dim iLastRow As Long

With ActiveSheet

iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To iLastRow
.Cells(i, "B").Value = Replace(.Cells(i, "B").Value, "~", .Cells(i, "A").Value)
Next i

End With

End Sub
[/vba]

[quanto]

Thank you! That's what I need.

However your macro distorts all the formatting in colum B.

I tested it 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 you amend the macro so not to preserve the original formatting?

Thanks again!

[vba]

Public Sub ProcessData()
Dim i As Long
Dim iLastRow As Long

With ActiveSheet

iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To iLastRow
.Cells(i, "B").Value = Replace(.Cells(i, "B").Value, "~", .Cells(i, "A").Value)
Next i

End With

End Sub
[/vba]

[quanto]

I meen to preserve the original formatting. Sorry for the typo

[CBrine]

quanto,
Give this a try. It uses a little bit different concept from xld's code(His overwrites the data in the cell, mine inserts at the point the ~ is found), and seems to keep the formating of the cell.

[VBA]
Dim wb As Workbook, ws As Worksheet, cell As Range
Dim count As Integer
Set wb = ActiveWorkbook
Set ws = ActiveSheet
For Each cell In ws.Range("B2", ws.Range("B" & ws.Rows.count).End(xlUp))
Do Until count > Len(cell)
If cell.Characters(count, 1).Text = "~" Then
cell.Characters(count, 1).Delete
cell.Characters(count).Insert cell.Offset(0, -1) & cell.Characters(count, Len(cell)).Text
End If
count = count + 1
Loop
count = 0
Next cell
[/VBA]

HTH
Cal

[quanto]

Hi Cal,

I used your code but an error occured:

Runtime error '1004'

Delete method of Character class failed

And the debugger stops at:

cell.Characters(count, 1).Delete

quanto,
Give this a try. It uses a little bit different concept from xld's code(His overwrites the data in the cell, mine inserts at the point the ~ is found), and seems to keep the formating of the cell.

[vba]
Dim wb As Workbook, ws As Worksheet, cell As Range
Dim count As Integer
Set wb = ActiveWorkbook
Set ws = ActiveSheet
For Each cell In ws.Range("B2", ws.Range("B" & ws.Rows.count).End(xlUp))
Do Until count > Len(cell)
If cell.Characters(count, 1).Text = "~" Then
cell.Characters(count, 1).Delete
cell.Characters(count).Insert cell.Offset(0, -1) & cell.Characters(count, Len(cell)).Text
End If
count = count + 1
Loop
count = 0
Next cell
[/vba]

HTH
Cal

[maytas]

Hi quanto.
Try this.
[VBA]Public Sub ProcessData()
Dim i As Long, iLastRow As Long, x As Long
Dim NewString As String
With ActiveSheet

iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To iLastRow
x = 0
Do While InStr(x + 1, .Cells(i, "B"), "~") > 0
x = InStr(x + 1, .Cells(i, "B"), "~")
If x <> 0 Then
NewString = CStr(.Cells(i, "A"))
With .Cells(i, "B").Characters(Start:=x, Length:=1)
.Insert (NewString)
End With
End If
Loop
Next i
End With
End Sub[/VBA]

[CBrine]

quanto,
I have attached a copy of the test I put together. It might help you figure out what's going wrong.

Cal

[Zack Barresse]

Is it always replaced with the value in A1? If so, no loop is needed...

[VBA] wRange("B:B").Replace "~~", Cells(1, 1).Value[/VBA]

Of course if you wanted to qualify your sheet/book, you would add them in..

[VBA] Dim wb As Workbook, ws As Worksheet
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
ws.Range("B:B").Replace "~~", ws.Cells(1, 1).Value[/VBA]

Of course if I did read it wrong and you have a specific entry for each value in their respective rows, you might, depending on your specifics, find it is faster to do it all at once...

[VBA]Sub FormulaReplace()
Dim wb As Workbook, ws As Worksheet
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
ws.Columns(3).Insert 'will preserve formatting
With ws.Range("C2:C" & ws.Cells(ws.Rows.count, "B").End(xlUp).Row)
.Formula = "=SUBSTITUTE(B2,""~"",A2)"
.Value = .Value
End With
ws.Columns(2).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub[/VBA]

HTH

[quanto]

Hi HTH,

Thank you for your involvement in my problem.

Find below attached an extract of the database I have to process: Before.xls

Each row contains different headword (in Column A). This headword has to replace the tilde sign (~) in the cell on the same row but in column B.

The content of column B has RTF formatting - bold, italic and red font.

When I use the macro suggested above. The bold and italic disappear and the whole text of the cells where ~ is replaced turns to red font.

You can try yourself on Before.xls.

Is it always replaced with the value in A1? If so, no loop is needed...

[vba] wRange("B:B").Replace "~~", Cells(1, 1).Value[/vba]

Of course if you wanted to qualify your sheet/book, you would add them in..

[vba] Dim wb As Workbook, ws As Worksheet
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
ws.Range("B:B").Replace "~~", ws.Cells(1, 1).Value[/vba]

Of course if I did read it wrong and you have a specific entry for each value in their respective rows, you might, depending on your specifics, find it is faster to do it all at once...

[vba]Sub FormulaReplace()
Dim wb As Workbook, ws As Worksheet
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
ws.Columns(3).Insert 'will preserve formatting
With ws.Range("C2:C" & ws.Cells(ws.Rows.count, "B").End(xlUp).Row)
.Formula = "=SUBSTITUTE(B2,""~"",A2)"
.Value = .Value
End With
ws.Columns(2).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub[/vba]

HTH

[quanto]

Hi maytas,

Your macro stops on this line: .Insert (NewString)

See the screenshot with the error attached

Hi quanto.
Try this.
[vba]Public Sub ProcessData()
Dim i As Long, iLastRow As Long, x As Long
Dim NewString As String
With ActiveSheet

iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To iLastRow
x = 0
Do While InStr(x + 1, .Cells(i, "B"), "~") > 0
x = InStr(x + 1, .Cells(i, "B"), "~")
If x <> 0 Then
NewString = CStr(.Cells(i, "A"))
With .Cells(i, "B").Characters(Start:=x, Length:=1)
.Insert (NewString)
End With
End If
Loop
Next i
End With
End Sub[/vba]

[CBrine]

quanto,
The code I attached in the workbook does exactly what you are asking. Take a look at the workbook and try and run it in the example. In my test everything works perfect, and should for you. If the example sheet works for you then, you have implemented it in your code incorrected and that's why you are getting the error.

Zack,
Does your second solution keep the formatting of the current cell? That's the major problem the OP is trying to address.

[Zack Barresse]

Yes, it keeps the formatting from the column. It's a byproduct from the Insert method by bordering the column of interest. That is why it is not another column.

[maytas]

Hi maytas,

Your macro stops on this line: .Insert (NewString)

See the screenshot with the error attached

Hi quanto.
For the explanation this problem see below link.

http:--support.microsoft.com/kb/158659#appliesto (Replace "--" with "//"

[Zack Barresse]

maytas, did any of my solutions work for you? I think you'll find the latter more suited to your needs.

[maytas]

maytas, did any of my solutions work for you? I think you'll find the latter more suited to your needs.

Sorry for my bad english in advance.
firefytr, when I testing your solution on quanto's atached book's Before.xls, I saw that your solution is not 100%, but it not keeps all formates in Columns(2).
Did you test your solution on Before.xls?

Best Regards.

[Zack Barresse]

Ah, I see. I tested with Book1.xls, not Before.xls. You have individual cell character formatting, which my solution would not take care of. I see.