Clever-Excel-Forum

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!

Ohne Beispieldatei ? :22:

Hallo,

hier wie gewünscht eine kleine Beispieldatei im Anhang.

ups...Datei vergessen

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ß

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.

Zitat: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.

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!

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ß

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

sharky51

snb

sharky51

maninweb

sharky51

snb

sharky51

maninweb

sharky51