AW: Weitere Nachfragen
31.01.2006 16:14:13
Martin
Hallo Uwe,
für den Fall, daß Zellen ohne "to" nicht in Spalte B übernommen werden sollen:
Sub to_austauschen()
Application.ScreenUpdating = False
Columns("A:A").Copy
Columns("B:B").PasteSpecial Paste:=xlPasteFormats
z = Range("A65536").End(xlUp).Row
For i = 1 To z
ber = Cells(i, 1)
If Len(ber) > Len(Application.WorksheetFunction.Substitute(ber, " to ", " ")) Then
z1 = Application.WorksheetFunction.Find(" to ", ber)
z2 = Application.WorksheetFunction.Find(" ", ber, z1 + 4)
txt1 = Mid(ber, z1, 4)
txt2 = Mid(ber, z1 + 4, z2 - z1 - 4)
zuers = txt1 & txt2
ber = Application.WorksheetFunction.Substitute(ber, zuers, " " & txt2 & " (to)")
Cells(i, 2) = ber
z3 = Application.WorksheetFunction.Find(";", ber)
Cells(i, 2).Characters(Start:=z3, Length:=Len(ber)).Font.FontStyle = "Fett"
End If
Next i
Application.ScreenUpdating = True
End Sub
Falls eine Übernahme dieser Zellen in Spalte B erwünscht ist:
Sub to_austauschen_2()
Application.ScreenUpdating = False
Columns("A:A").Copy
Columns("B:B").PasteSpecial Paste:=xlPasteFormats
z = Range("A65536").End(xlUp).Row
For i = 1 To z
ber = Cells(i, 1)
If Len(ber) > Len(Application.WorksheetFunction.Substitute(ber, " to ", " ")) Then
z1 = Application.WorksheetFunction.Find(" to ", ber)
z2 = Application.WorksheetFunction.Find(" ", ber, z1 + 4)
txt1 = Mid(ber, z1, 4)
txt2 = Mid(ber, z1 + 4, z2 - z1 - 4)
zuers = txt1 & txt2
ber = Application.WorksheetFunction.Substitute(ber, zuers, " " & txt2 & " (to)")
Cells(i, 2) = ber
z3 = Application.WorksheetFunction.Find(";", ber)
Cells(i, 2).Characters(Start:=z3, Length:=Len(ber)).Font.FontStyle = "Fett"
End If
Next i
For Each cell In Columns("B:B").SpecialCells(xlCellTypeBlanks)
cell.Offset(0, -1).Copy Destination:=cell
Next
Application.ScreenUpdating = True
End Sub
Gruß
Martin Beck