Anzeige
Archiv - Navigation
704to708
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
704to708
704to708
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Unterstrichene Worte verschieben

Unterstrichene Worte verschieben
06.12.2005 07:46:58
Uwe
Hallo,
kann man in einer Tabellenzeile die unterstrichenen Wörter stehen lassen und die nicht-unterstrichenen in Spalte B rücken?
Spalte A
aaaaaaa (unterstrichen) bbbbbb cccccc dddddd
ergibt
Spalte A Spalte B
aaaaaa bbbbbb cccccc dddddd
Gruss,
Uwe

11
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Unterstrichene Worte verschieben
06.12.2005 08:07:38
Harald E
Moin Uwe,
Bereich: Zeile 1 bis letzte gefüllte Zelle in Spalte A

Sub Makro1()
Dim i As Long
Lrow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To Lrow
If Cells(i, 9).Font.Underline = xlUnderlineStyleSingle Then
Cells(i, 10) = Cells(i, 9)
'Cells(i, 10).Font.Underline = xlUnderlineStyleSingle
Cells(i, 9).ClearContents
End If
Next i
End Sub

Gruss Harald
AW: Unterstrichene Worte verschieben
06.12.2005 08:32:44
Uwe
Hallo Harald,
klappt nicht - habe ein Beispieldokument angehangen.
Gruss und danke,
Uwe

Die Datei https://www.herber.de/bbs/user/28995.xls wurde aus Datenschutzgründen gelöscht

Anzeige
Muss ich offen lassen
06.12.2005 09:18:29
Harald E
So gut bin ich noch nicht und F1 gibt auch nix her ;-(
Sorry. Bin aber auf die Lösung gespannt.
Gruss Harald
Neue Lösung
06.12.2005 09:32:36
Heiko S.
Hallo Uwe,
so könnte es gehen:

Sub Unterstrichen()
Dim lngI As Long, lngS As Long, lngE As Long, lngN As Long
For lngN = 1 To ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
lngI = 0
lngS = 0
lngE = 0
If Cells(lngN, 1).Text <> "" Then
For lngI = 1 To Len(Cells(lngN, 1).Text)
If Cells(lngN, 1).Characters(lngI, 1).Font.Underline = 2 Then
If lngS = 0 Then
lngS = lngI
End If
Else
If lngS <> 0 And lngE = 0 Then
lngE = lngI
End If
End If
Next lngI
If lngS < lngE Then
Cells(lngN, 1).Offset(0, 1) = Right(Cells(lngN, 1).Text, Len(Cells(lngN, 1).Text) - lngE)
Cells(lngN, 1) = Left(Cells(lngN, 1).Text, lngE)
End If
End If
Next lngN
End Sub

Gruß Heiko
PS: Rückmeldung wäre nett !
Anzeige
Kleine aber feine Ergänzung
06.12.2005 09:41:09
Heiko S.
Hallo Uwe,
so sollte es aber nun gehen:

Sub Unterstrichen()
Dim lngI As Long, lngS As Long, lngE As Long, lngN As Long
For lngN = 1 To ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
lngI = 0
lngS = 0
lngE = 0
If Cells(lngN, 1).Text <> "" Then
For lngI = 1 To Len(Cells(lngN, 1).Text)
If Cells(lngN, 1).Characters(lngI, 1).Font.Underline = 2 Then
If lngS = 0 Then
lngS = lngI
End If
Else
If lngS <> 0 And lngE = 0 Then
lngE = lngI
End If
End If
Next lngI
If lngS < lngE Then
Cells(lngN, 1).Offset(0, 1) = Right(Cells(lngN, 1).Text, Len(Cells(lngN, 1).Text) - lngE)
Cells(lngN, 1) = Left(Cells(lngN, 1).Text, lngE)
ElseIf lngS = 0 And lngE = 0 Then
Cells(lngN, 1).Offset(0, 1) = Cells(lngN, 1).Text
End If
End If
Next lngN
End Sub

Gruß Heiko
PS: Rückmeldung wäre nett !
Anzeige
AW: Kleine aber feine Ergänzung
06.12.2005 10:24:08
Uwe
Danke, funktioniert bis auf eine kleine Sache ..... wenn in einer Zeile nichts unterstrichen ist soll der Text auch nach rechts kopiert werden.
Gruss,
Uwe
AW: Kleine aber feine Ergänzung
06.12.2005 12:00:11
Heiko S.
Hallo Uwe,
na dann so:

Sub Unterstrichen()
Dim lngI As Long, lngS As Long, lngE As Long, lngN As Long
For lngN = 1 To ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
lngI = 0
lngS = 0
lngE = 0
If Cells(lngN, 1).Text <> "" Then
For lngI = 1 To Len(Cells(lngN, 1).Text)
If Cells(lngN, 1).Characters(lngI, 1).Font.Underline = 2 Then
If lngS = 0 Then
lngS = lngI
End If
Else
If lngS <> 0 And lngE = 0 Then
lngE = lngI
End If
End If
Next lngI
If lngS < lngE Then
Cells(lngN, 1).Offset(0, 1) = Right(Cells(lngN, 1).Text, Len(Cells(lngN, 1).Text) - lngE)
Cells(lngN, 1) = Left(Cells(lngN, 1).Text, lngE)
ElseIf lngS = 0 And lngE = 0 Then
Cells(lngN, 1).Offset(0, 1) = Cells(lngN, 1).Text
Cells(lngN, 1) = ""
End If
End If
Next lngN
End Sub

Gruß Heiko
PS: Rückmeldung wäre nett !
Anzeige
AW: Kleine aber feine Ergänzung
06.12.2005 12:00:23
Erich G.
Hallo Uwe,
probierst du mal bitte

Sub Verschieben3()
Dim ii As Long, pp As Integer
Dim strMit As String, strOhne As String
Dim varUStyleAkt As XlUnderlineStyle, varUStyle As XlUnderlineStyle
For ii = 1 To Cells(Rows.Count, 1).End(xlUp).Row
strOhne = ""
strMit = ""
For pp = 1 To Len(Cells(ii, 1))
varUStyleAkt = Cells(ii, 1).Characters(pp, 1).Font.Underline
If varUStyleAkt = xlUnderlineStyleNone Then
strOhne = strOhne & Mid(Cells(ii, 1), pp, 1)
Else
strMit = strMit & Mid(Cells(ii, 1), pp, 1)
varUStyle = varUStyleAkt
End If
Next pp
With Cells(ii, 1)
.Value = Trim(strMit)
.Font.Underline = varUStyle
End With
Cells(ii, 2) = Trim(strOhne)
Next ii
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
Anzeige
AW: Kleine aber feine Ergänzung
06.12.2005 12:51:47
Erich G.
Hallo Uwe,
kann auch so etwas in Spalte A vorkommen?
AW: Unterstrichene Worte verschieben
06.12.2005 09:20:04
Erich G.
Hallo Uwe,
das Ergebnis ist nicht hundertprozentig so, wie du es angegeben hast - es unterscheidet sich bei den Leerzeichen. Liegt aber wohl an deren (Nicht-)Unterstreichung.

Option Explicit
Sub Verschieben()
Dim Lrow  As Long, ii As Long, pp As Integer
Dim strMit As String, strOhne As String
Lrow = Cells(Rows.Count, 1).End(xlUp).Row
For ii = 1 To Lrow
strOhne = ""
strMit = ""
For pp = 1 To Len(Cells(ii, 1))
If Cells(ii, 1).Characters(pp, 1).Font.Underline = _
xlUnderlineStyleNone Then
strOhne = strOhne & Mid(Cells(ii, 1), pp, 1)
Else
strMit = strMit & Mid(Cells(ii, 1), pp, 1)
End If
Next pp
Cells(ii, 1) = strMit
Cells(ii, 2) = strOhne
Next ii
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
Anzeige
AW: auch eine Ergänzung...
06.12.2005 09:50:31
Erich G.
Hallo Uwe,
da möchte ich nicht zurückstehen und auch eine Ergänzung posten ;-)
Wenn die Leerzeichen am Anfang und Ende stören sollten:

Option Explicit
Sub Verschieben2()
Dim ii As Long, pp As Integer
Dim strMit As String, strOhne As String
For ii = 1 To Cells(Rows.Count, 1).End(xlUp).Row
strOhne = ""
strMit = ""
For pp = 1 To Len(Cells(ii, 1))
If Cells(ii, 1).Characters(pp, 1).Font.Underline = _
xlUnderlineStyleNone Then
strOhne = strOhne & Mid(Cells(ii, 1), pp, 1)
Else
strMit = strMit & Mid(Cells(ii, 1), pp, 1)
End If
Next pp
Cells(ii, 1) = Trim(strMit)
Cells(ii, 2) = Trim(strOhne)
Next ii
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige