Excel vba Stringaufteilung in einer Zelle

[sharky51]

Hallo zusammen,

ich knoble gerade an einer Aufgabe, bei der ich mal wieder nicht weiterkomme und hoffe auf Eure Hilfe.

Vielleicht ist mein Ansinnen ja etwas abstrus, möchte die Problematik aber trotzdem mal kurz beschreiben.

In Zellen werden unterschiedlich lange Textstrings eingetragen. Nun möchte ich per Makro erreichen, dass in bestimmten Zellen, wobei zwei Zellen aufeinander folgen,
der Textinhalt der Zelle mit einem Zusatzstring erweitert wird.

Das kann man einfach tun, indem man an den vorhandenen String etwas dranhängt. Soweit so gut.

Ich möchte aber erreichen, dass der anzuhängende Zusatz unabhängig von der Spaltenbreite der Zelle ganz rechts am Zellenende steht.
Habe das in dem beigefügten Makro bisher so gelöst, dass ich ein paar Blanks eingefügt habe.... das gefällt mir so aber nicht weil die Stringlänge variiert.

Code:

Sub TextPartColour()
  ' Declarations and Initialisation
  Dim rowX As Integer, colX As Integer
  Dim CurrentCellText As String
  Dim StartPosition
  Dim EndPosition
  Dim lenText
  Dim newText
 
  colX = ActiveCell.Column
  rowX = ActiveCell.Row
 
  'Get Text in Current Cell
  CurrentCellText = ActiveSheet.Cells(rowX, colX).Value
 
  'Get the Position of the Text
  lenText = Len(CurrentCellText)
  newText = CurrentCellText & "    von WR"
  StartPosition = InStr(1, newText, "    von WR")
  EndPosition = InStr(1, CurrentCellText, "    bis WR")
  ActiveSheet.Cells(rowX, colX).Value = newText
  lenText = Len(ActiveSheet.Cells(rowX, colX).Value)
 
  'Colour the Word "von WR" Red
  If StartPosition > 0 Then
      ActiveSheet.Cells(rowX, colX).Characters(StartPosition, lenText).Font.Color = RGB(255, 0, 0)
      ActiveSheet.Cells(rowX, colX).Characters(StartPosition, lenText).Font.Bold = True
  End If
 
  ActiveCell.Offset(1, 0).Select
 
  'Get Text in Current Cell
  CurrentCellText = ActiveSheet.Cells(rowX + 1, colX).Value
  newText = CurrentCellText & "    bis WR"
  EndPosition = InStr(1, newText, "    bis WR")
  ActiveSheet.Cells(rowX + 1, colX).Value = newText
  lenText = Len(CurrentCellText)
 
  'Colour the Word "von WR" Blue
  If StartPosition > 0 Then
      ActiveSheet.Cells(rowX + 1, colX).Characters(EndPosition, lenText).Font.Color = RGB(0, 0, 255)
      ActiveSheet.Cells(rowX + 1, colX).Characters(EndPosition, lenText).Font.Bold = True
  End If
End Sub

Wäre schön, wenn Ihr mir mal wieder helfen könntet!

[snb]

Ohne Beispieldatei ? :22:

[sharky51]

Hallo,

hier wie gewünscht eine kleine Beispieldatei im Anhang.

---

ups...Datei vergessen

[maninweb]

Hallo,

ich würde Dir ja eher empfehlen, eine zweite Spalte für Deine additiven Texte zu verwenden. So wirst Du das nicht hinbekommen,
es immer rechtsbündig darzustellen, ausser Du änderst die Schriftart auf eine nicht-variable Breite, wie Consolas.

Gruß

[sharky51]

Hallo,

danke für Deinen Vorschlag.

Eine zusätzliche Spalte möchte ich aber unbedingt vermeiden.
Wenn ich die Schriftart "Consolas" verwende ist bei unterschiedlichen Stringlängen das Problem auch noch nicht gelöst.

[snb]

Eine zusätzliche Spalte möchte ich aber unbedingt vermeiden.
Wenn ich die Schriftart "Consolas" verwende ist bei unterschiedlichen Stringlängen das Problem auch noch nicht gelöst.

Warum vermeiden ?

Warum ist das ein 'Problem' ?

Argumente fehlen.

[sharky51]

Hallo,

Warum vermeiden?
- Weil ich keine zusätzliche Spalte in der Tabelle haben möchte/darf.

Warum ist das ein Problem?
- Weil ich nicht weiß, wie man das programmtechnisch lösen könnte.

Hatte das Vorhaben ja schon beschrieben.

Ich gehe davon aus, dass diese Parameter für eine mögliche Umsetzung benötigt werden:

- Nun ausgehend von der Schriftart "Consolas" muss die jeweilige Stringlänge berechnet werden
- die Zellenbreite sollte ermittelt werden, also wie viele Zeichen von der Schriftart "Consolas" passen in diese Zelle
- der Rest der der Zelle der noch nicht durch den String belegt ist notwendig
- die Länge des anzuhängenden Teilstrings ist notwendig
- die Anzahl der Leerzeichen die notwendig sind um den Teilstring nach rechts in der Zelle zu verschieben.

Das fällt mir so dazu ein was notwendig sein könnte - vielleicht geht es auch einfacher!

Aber wie gesagt bekomme ich das nicht selbst hin... und deshalb mein Hilferuf!

[maninweb]

Hallo,

ich habe Dir mal Dein Makro angepasst, ohne jetzt sonstige weitere Vereinfachungen vorzunehmen.
Du brauchst eine feste Breite - hier 60 + 6 Zeichen additiver String - damit das klappt.

Code:

Sub TextPartColour()

  Dim rowX As Long
  Dim colX As Long
  Dim CurrentCellText As String
  Dim StartPosition As Long
  Dim newText As String
 
  colX = ActiveCell.Column
  rowX = ActiveCell.Row
 
  CurrentCellText = ActiveSheet.Cells(rowX, colX).Value
  newText = CurrentCellText & String(60 - Len(CurrentCellText), " ") & "von WR"
  StartPosition = InStr(1, newText, "von WR")
  ActiveSheet.Cells(rowX, colX).Value = newText
 
  If StartPosition > 0 Then
      ActiveSheet.Cells(rowX, colX).Characters(StartPosition, 6).Font.Color = RGB(255, 0, 0)
      ActiveSheet.Cells(rowX, colX).Characters(StartPosition, 6).Font.Bold = True
  End If
 
  CurrentCellText = ActiveSheet.Cells(rowX + 1, colX).Value
  newText = CurrentCellText & String(60 - Len(CurrentCellText), " ") & "bis WR"
  StartPosition = InStr(1, newText, "bis WR")
  ActiveSheet.Cells(rowX + 1, colX).Value = newText
 
  If StartPosition > 0 Then
      ActiveSheet.Cells(rowX + 1, colX).Characters(StartPosition, 6).Font.Color = RGB(0, 0, 255)
      ActiveSheet.Cells(rowX + 1, colX).Characters(StartPosition, 6).Font.Bold = True
  End If
 
End Sub

Gruß

[sharky51]

Hallo und schönen guten Abend,

das ist cool und funktioniert super, vielen Dank für diese Lösung!

In der Zwischenzeit habe ich versucht die Aufgabe auch zu lösen.
Ist sicher nicht so elegant, aber immerhin.

Hier meine Version:

Code:

'Aktuellen String in Zelle erweitern - Erweiterung an def. Position schreiben
Sub StringErweiterung()
  Dim strText As String  'Textlänge
  Dim lngCell              'Zellenlänge
  Dim restlng              'Restlänge
  Dim spacelng            'Anzahl Leerzeichen
  Dim txtlng              'Länge Zusatztext
  Dim gapEoL              'Offset am Zellende
 
  'Zuerst die gewünsche nichtproportionale Schriftart einstellen
  ActiveCell.Font.Name = "Consolas"
 
  lngCell = ActiveCell.ColumnWidth
  'MsgBox Chr(64 + i) & "Breite der Zelle: " & ActiveCell.ColumnWidth
 
  gapEoL = 1
  txtlng = 6
 
  'Erste Textzeile zusammensetzen
  strText = ActiveCell.Value
  lenText = Len(strText)
  restlng = lngCell - Len(strText)
  spacelng = (restlng - gapEoL) - txtlng
 
  If Len(strText) + gapEoL >= lngCell Then
      MsgBox "Textlänge passt nicht für die aktuelle Zellenbreite!"
      Exit Sub
  Else
      strText = strText & Application.Rept(" ", spacelng) & "von WR"
      MsgBox strText & " Länge " & Len(strText)
      ActiveCell.Value = strText
  End If
 
  'Zweite Textzeile zusammensetzen
  Selection.Offset(1, 0).Select
  'Zuerst die gewünsche nichtproportionale Schriftart einstellen
  ActiveCell.Font.Name = "Consolas"
  strText = ActiveCell.Value
  lenText = Len(strText)
  restlng = lngCell - Len(strText)
  spacelng = (restlng - gapEoL) - txtlng
 
  If Len(strText) + gapEoL >= lngCell Then
      MsgBox "Textlänge passt nicht für die aktuelle Zellenbreite!"
      Exit Sub
  Else
      strText = strText & Application.Rept(" ", spacelng) & "bis WR"
      MsgBox strText & " Länge " & Len(strText)
      ActiveCell.Value = strText
  End If
End Sub