Live-Forum - Die aktuellen Beiträge
Datum
Titel
16.10.2025 18:38:17
Zusammenfassung nach Personalnummer
16.10.2025 17:40:39
Rabattstafel
16.10.2025 17:25:38
bedingte Formatierung
16.10.2025 16:39:53
Ergebnisse nach rechts ausgeben
Keine passende Antwort im Forumarchiv gefunden?
Stelle deine Frage im Live-Forum
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
704to708
704to708
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Unterstrichene Worte verschieben

Forumthread: 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
Anzeige

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
Anzeige
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

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
Anzeige
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)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Entdecke mehr
Finde genau, was du suchst

Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden

Suche nach den besten Antworten
Unsere beliebtesten Threads

Entdecke unsere meistgeklickten Beiträge in der Google Suche

Top 100 Threads jetzt ansehen
Anzeige