Thema: Spalte auf Textlänge überprüfen & statt Umbruch, neue Zeile

Hallo zusammen,

ich möchte die Zellen in Spalte D (D3) vor der Textlänge 15 Zeichen,
auf eine neu eingefügte Zeile umbrechen und keinen Zeilenumbruch innerhalb der Zelle vornehmen.
Leerzellen sollen ignoriert werden.

Sub TrennenNachXZeichen()



Dim Wort As String

Dim Cut As Integer

Dim i As Integer

Dim Wörter

Dim Zeile()

Dim a

Cut = 15



Wort = Cells(3, 4).Value

Wort = Application.WorksheetFunction.Substitute(Wort, vbLf, " ")



    'trennen davor

    ReDim Zeile(0)

    a = 0

    Wörter = Split(Wort, " ")

    Zeile(0) = Wörter(0)

    

    For i = 0 To UBound(Wörter) - 1

        If Len(Zeile(a)) + Len(Wörter(i + 1)) > Cut Then

            a = a + 1

            ReDim Preserve Zeile(a)

            Zeile(a) = Wörter(i + 1)

        Else

            Zeile(a) = Zeile(a) & " " & Wörter(i + 1)

        End If

    Next i

    

    Cells(1, 4) = Join(Zeile, vbCrLf)

    

End Sub

UND? Wo ist jetzt das Problem oder die Frage ???
Ausserdem:
Wozu "Application.WorksheetFunction.Substitute" ? Es gibt den Replace-Befehl von VBA.

Hallo Tobi,

ersetze

    Cells(1, 4) = Join(Zeile, vbCrLf)

durch

    Rows(2).Resize(UBound(Zeile)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

    Zeile = Application.Transpose(Zeile)

    Cells(1, 4).Resize(UBound(Zeile)).Value = Zeile

Gruß, Uwe

Moin Uwe,

danke, für die Unterstützung.
Es funktioniert leider nur für die erste Zelle, und wenn in der Spalte leere Zellen sind läuft der Code in einen Fehler.

Der Fehler liegt an der Schleife, ich selbst komm aber mit meinem Wissen nicht weiter.

Fehler Leerzellen:
Zeile(0) = Wörter(0) verursacht den Fehler

Hier ist nochmal der überarbeitete Code:

Gruß Tobias

Sub TrennenNachXZeichen()



Dim Wort As String

Dim Cut As Integer

Dim i As Integer

Dim Wörter

Dim Zeile()

Dim a

Cut = 15



Wort = Cells(3, 4).Value

Wort = Application.WorksheetFunction.Substitute(Wort, vbLf, " ")



    'trennen davor

    ReDim Zeile(0)

    a = 0

    Wörter = Split(Wort, " ")

    Zeile(0) = Wörter(0)

    

    For i = 0 To UBound(Wörter) - 1

        If Len(Zeile(a)) + Len(Wörter(i + 1)) > Cut Then

            a = a + 1

            ReDim Preserve Zeile(a)

            Zeile(a) = Wörter(i + 1)

        Else

            Zeile(a) = Zeile(a) & " " & Wörter(i + 1)

        End If

    Next i

    

    Rows(4).Resize(UBound(Zeile)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

    Zeile = Application.Transpose(Zeile)

    Cells(3, 4).Resize(UBound(Zeile)).Value = Zeile

    

End Sub

Hallo Tobias,

Dein Code war ja auch nur für eine Zelle programmiert. Habe es erweitert für alle Zellen einer Spalte (hier 4 für D) inklusive Berücksichtigung leerer Zellen:

Sub TrennenNachXZeichen_Kuwer()

  Const lngCut As Long = 15

  Dim a As Long

  Dim i As Long

  Dim lngZ As Long

  Dim vWoerter As Variant

  Dim vZeile() As Variant



  For lngZ = Cells(Rows.Count, 4).End(xlUp).Row To 3 Step -1

    vWoerter = Split(Application.Substitute(Cells(lngZ, 4).Value, vbLf, " "), " ")

    If UBound(vWoerter) > -1 Then

      ReDim vZeile(0)

      a = 0

      vZeile(0) = vWoerter(0)

      

      For i = 0 To UBound(vWoerter) - 1

          If Len(vZeile(a)) + Len(vWoerter(i + 1)) > lngCut Then

              a = a + 1

              ReDim Preserve vZeile(a)

              vZeile(a) = vWoerter(i + 1)

          Else

              vZeile(a) = vZeile(a) & " " & vWoerter(i + 1)

          End If

      Next i

      

      If UBound(vZeile) > 0 Then

        Rows(lngZ + 1).Resize(UBound(vZeile)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

        vZeile = Application.Transpose(vZeile)

        Cells(lngZ, 4).Resize(UBound(vZeile)).Value = vZeile

      End If

    End If

  Next lngZ

End Sub

Gruß, Uwe

Hallo Uwe,

es ist immer wieder erstaunlich wie ihr so etwas hinbekommt.

Vielen Dank.

Gruß Tobias :-)

Hallo,

wie kann ich in dem Code eine Längenumschaltung einbauen?

Mein Versuch ist leider ohne Erfolg "Mehrfach deklaration im aktuellen Bereich".

Bevor der Text in Spalte 4 eingekürzt wird, möchte ich Spalte 4 nach der Größe abfragen.

Gruß Tobias

If Cells(lngZ, 8).Value = "26x52" Then

    Const lngCut As Long = 13

ElseIf Cells(lngZ, 8).Value = "37x44" Then

    Const lngCut As Long = 8

ElseIf Cells(lngZ, 8).Value = "26x140" Then

    Const lngCut As Long = 20

End If

Hallo Tobias,

Konstanten sind nicht mehr änderbar, deshalb wieder als "normale" Variable:

Sub TrennenNachXZeichen_2_Kuwer()

  Dim a As Long, i As Long

  Dim lngCut As Long, lngZ As Long

  Dim vWoerter As Variant, vZeile() As Variant



  For lngZ = Cells(Rows.Count, 4).End(xlUp).Row To 3 Step -1

    vWoerter = Split(Application.Substitute(Cells(lngZ, 4).Value, vbLf, " "), " ")

    If UBound(vWoerter) > -1 Then

      ReDim vZeile(0)

      a = 0

      vZeile(0) = vWoerter(0)

      Select Case Cells(lngZ, 8).Value

        Case Is = "26x52"

          lngCut = 13

        Case Is = "37x44"

          lngCut = 8

        Case Is = "26x140"

          lngCut = 20

        Case Else 'wenn keines der anderen zutrifft

          lngCut = 15

      End Select

      For i = 0 To UBound(vWoerter) - 1

        If Len(vZeile(a)) + Len(vWoerter(i + 1)) > lngCut Then

          a = a + 1

          ReDim Preserve vZeile(a)

          vZeile(a) = vWoerter(i + 1)

        Else

          vZeile(a) = vZeile(a) & " " & vWoerter(i + 1)

        End If

      Next i

      If UBound(vZeile) > 0 Then

        Rows(lngZ + 1).Resize(UBound(vZeile)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

        vZeile = Application.Transpose(vZeile)

        Cells(lngZ, 4).Resize(UBound(vZeile)).Value = vZeile

      End If

    End If

  Next lngZ

End Sub

Gruß, Uwe

Hallo mal wieder,

das mit dem "Select Case" gefällt mir, ich möchte das jetzt auch noch weiter führen, komm aber mal wieder nicht weiter.
Folgende Situation, je nach "Case" möchte ich gern Zellwerte wiederholt befüllen.
Nur leider weiß ich nicht, als was ich "Dim CharBMK As ?, CharSze As ?" deklarieren muss damit es funktioniert.
Oder ich mach etwas anderes falsch.

Gruß Tobias

Dim anzahlGESAMT As Long, Anzahl As Long

Dim cell As Range, adr5 As Range, rws As Range

Dim anzahlGESAMT As Long, Anzahl As Long





    ' Tabelle auszählen

        Set adr5 = Worksheets("EplSheet").Range("G2:G500" & Cells(Rows.Count, 1).End(xlUp).Row)

        anzahlGESAMT = Application.WorksheetFunction.CountA(adr5)





  With Worksheets("Druck")

        For i = 0 To anzahlGESAMT - 1 ' x beliebige Wierderholung in 1er Reihenschritten

       

        ' Schildergröße: Druck Spalte H(8) aus EplSheet Spalte K(11) einlesen

            .Cells(1 + i, 8).Value = Worksheets("EplSheet").Cells(2 + i, 11).Value

        

        

'        Dim CharBMK As ?, CharSze As ?

        Select Case Cells(anzahlGESAMT, 8).Value

       

       '-------------------

        Case Is = "26x52"

          CharBMK = Chr(10) _

                  + Chr(10) _

                  + Worksheets("EplSheet").Cells(2 + i, 8).Value

          

          CharSze = Worksheets("EplSheet").Cells(2 + i, 9).Value _

                  + Chr(10) _

                  + Worksheets("EplSheet").Cells(2 + i, 9).Value _

                  + Chr(10) _

                  + "3|" _

                  + Worksheets("EplSheet").Cells(2 + i, 9).Value    

       '-------------------

        Case Is = "37x52"

          CharBMK = Chr(10) _

                  + Chr(10) _

                  + Chr(10) _

                  + Worksheets("EplSheet").Cells(2 + i, 8).Value

          

          CharSze = Worksheets("EplSheet").Cells(2 + i, 9).Value _

                  + Chr(10) _

                  + Worksheets("EplSheet").Cells(2 + i, 9).Value _

                  + Chr(10) _

                  + Worksheets("EplSheet").Cells(2 + i, 9).Value _

                  + Chr(10) _

                  + "3|" _

                  + Worksheets("EplSheet").Cells(2 + i, 9).Value

       '-------------------

       'etc



        Case Else 'wenn keines der anderen zutrifft

          CharBMK = Chr(10) _

                  + Chr(10) _

                  + Chr(10) _

                  + Worksheets("EplSheet").Cells(2 + i, 8).Value

          

          CharSze = Worksheets("EplSheet").Cells(2 + i, 9).Value _

                  + Chr(10) _

                  + Worksheets("EplSheet").Cells(2 + i, 9).Value _

                  + Chr(10) _

                  + Worksheets("EplSheet").Cells(2 + i, 9).Value _

                  + Chr(10) _

                  + "3|" _

                  + Worksheets("EplSheet").Cells(2 + i, 9).Value

      

      End Select



        ' BMK: Druck Spalte C(3) aus EplSheet Spalte H(8) einlesen

            .Cells(1 + i, 3).Value = CharBMK

        ' Schriftgröße Druck Spalte F(6) aus EplSheet Spalte I(9) einlesen

            .Cells(1 + i, 6).Value = CharSze



        Next i

'.

'.

   End With

End Sub

Hallo,
Strings werden in VBA mit & verknüpft und nicht mit +.

Gruß aus'm Pott
Udo

Danke, hat sich erledigt, habe meinen Fehler gefunden.

Gruß Tobias

Moin,

wenn man denkt man hat ein Problem gelöst und man etwas funktionierendes wieder kaputt macht...
Für die "anzahlGESAMT"-Schleife wollte ich lediglich die "Select Case" Abfrage einbauen, bin aber kläglich gescheitert.
Kann bitte jemand helfen.

Gruß Tobias

Dim EinzelneWorte() As String, Text As String

Dim i As Integer, lastRow As Integer, intRow As Integer, intLastRow As Integer

Dim cell As Range, adr5 As Range, adr4 As Range, rws As Range

Dim anzahlGESAMT As Long, Anzahl As Long, GESAMT As Long





' Tabelle auszählen

    Set adr5 = Worksheets("EplSheet").Range("G2:G500" & Cells(Rows.Count, 1).End(xlUp).Row)

    anzahlGESAMT = Application.WorksheetFunction.CountA(adr5)





' Tabelle auszählen '(?) Versuch für die "Select Case" Schleife

    Set adr6 = Worksheets("EplSheet").Range("K2:K500" & Cells(Rows.Count, 1).End(xlUp).Row)

    GESAMT = Application.WorksheetFunction.CountA(adr6)





    'ausser dem Lesen von Werten passiert alles auf dem Blatt "Druck"

        With Worksheets("Druck")

        

            .Range("B1:B100").ClearContents

            .Range("B1:B100") = "0"

            

            

        For GESAMT = Cells(Rows.Count, 4).End(xlUp).Row To 1 Step -1 '(?)

          

            Dim CharBMK As String, CharSze As String

            Select Case Cells(GESAMT, 8).Value '(?)

           

           '-------------------

            Case Is = "26x52"

              CharBMK = Chr(10) _

                      & Chr(10) _

                      & Worksheets("EplSheet").Cells(2 + i, 8).Value

              

              CharSze = Worksheets("EplSheet").Cells(2 + i, 9).Value _

                      & Chr(10) _

                      & Worksheets("EplSheet").Cells(2 + i, 9).Value _

                      & Chr(10) _

                      & "3|" _

                      & Worksheets("EplSheet").Cells(2 + i, 9).Value

                        

            Case Is = "37x52"

              CharBMK = Chr(10) _

                      & Chr(10) _

                      & Chr(10) _

                      & Worksheets("EplSheet").Cells(2 + i, 8).Value

              

              CharSze = Worksheets("EplSheet").Cells(2 + i, 9).Value _

                      & Chr(10) _

                      & Worksheets("EplSheet").Cells(2 + i, 9).Value _

                      & Chr(10) _

                      & Worksheets("EplSheet").Cells(2 + i, 9).Value _

                      & Chr(10) _

                      & "3|" _

                      & Worksheets("EplSheet").Cells(2 + i, 9).Value

           '-------------------

           'etc

    

            Case Else 'wenn keines der anderen zutrifft

              CharBMK = Chr(10) _

                      & Chr(10) _

                      & Chr(10) _

                      & Worksheets("EplSheet").Cells(2 + i, 8).Value

              

              CharSze = Worksheets("EplSheet").Cells(2 + i, 9).Value _

                      & Chr(10) _

                      & Worksheets("EplSheet").Cells(2 + i, 9).Value _

                      & Chr(10) _

                      & Worksheets("EplSheet").Cells(2 + i, 9).Value _

                      & Chr(10) _

                      & "3|" _

                      & Worksheets("EplSheet").Cells(2 + i, 9).Value

            End Select

        Next GESAMT '(?)

        



        For i = 0 To anzahlGESAMT - 1 ' x beliebige Wierderholung in 1er Reihenschritten

        

        ' BMK: Druck Spalte C(3) aus EplSheet Spalte H(8) einlesen

            .Cells(1 + i, 3).Value = CharBMK



        ' Schriftgröße Druck Spalte F(6) aus EplSheet Spalte I(9) einlesen

            .Cells(1 + i, 6).Value = CharSze

        Next i



End Sub

Hallo Tobias,

vergleiche doch mal mit diesem Code: https://www.herber.de/forum/messages/2006947.html
Achte auf den Bereich vor End Sub . ;-)

Gruß, Uwe

Hallo Uwe,

mit dem "Next GESAMT" nach "Next i" hab ich auch schon probiert, leider geht dann der Select Case nicht mehr.

Gruß Tobias.

Hallo,
(endlich mal) eine Beispieldatei mit Wunschergebnis hochladen.

Gruß aus'm Pott
Udo

Hllo Tobias,

ich meinte eher das fehlende

End With

Gruß, Uwe

Moin Uwe,
sorry, Asche auf mein Haupt, ich habe nur einen Ausschnitt vom Code gepostet weil der Rest funktioniert und dann nur End Sub eingefügt.
Wäre schön gewesen wenn es nur daran gelegen hätte, ich habe das Ganze jetzt aber anders gelöst.
Danke für die Unterstützung.
Gruß Tobias

Hallo Udo,

ich hab jetzt auf Select Case verzichtet und dafür eine If-Anweisung mit Else-If in meine For Schleife eingebaut.

Schönen Abend noch
Gruß Tobias