Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1464to1468
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
Inhaltsverzeichnis

Text in Zelle aufteilen u. untereinander schreiben

Text in Zelle aufteilen u. untereinander schreiben
07.01.2016 22:26:12
webrollo
Hallo liebes Forum,
ich brauche Eure Hilfe bei folgendem Problem:
Ich habe in einer Tabelle Text in den Zellen der Spalte E, der sich wegen der Begrenzung auf 256 Zeichen nicht vollständig in andere Tabellen kopieren lässt.
Ich bräuchte deshalb ein VBA Script, dass diese Zellen aufteilt.
Den Text in der Zelle am Leerzeichen orientiert trennt und in die Zellen unter der ursprünglichen Zelle schreibt, ohne die auch mit Text gefüllte Zelle darunter zu überschreiben.
Ich hatte schon ein fast passendes Script von Hajo Ziplies gefunden, kriege es aber einfach nicht hin, das so anzupassen wie ich es brauche. Dieses Script funktioniert nur, wenn der urspründliche Text in Zelle A1 steht und überschreibt leider auch den unter der aufzuteilenden Zelle stehenden Text in Zelle A2.
Hier das Script:

Attribute VB_Name = "mdl_Zeile"
Option Explicit                                     ' Variablendefinition erforderlich
Sub AufteilenZeile()
'* H. Ziplies                                  *
'* 24.04.2014                                  *
'* erstellt von HajoZiplies@web.de             *
'* http://Hajo-Excel.de
Dim Inletzte As Integer                         ' Variable letzte Spalte
Dim InI As Integer                              ' Schleifenvariable
Dim LoZeile As Long                             ' Variable Spalte
Dim StWert As String                            ' Variable für Zellinhalt
LoZeile = 1                                     ' erste Zeile in die was geschrieben werden  _
_
_
soll
Inletzte = IIf(IsEmpty(Cells(1, Columns.Count)), Cells(1, Columns.Count).End(xlToLeft). _
Column, Columns.Count)
Application.EnableEvents = False                ' Reaktion auf Zellveränderung abschalten
Application.ScreenUpdating = False              ' Bildschirmaktualisierung ausschalten
For InI = 1 To Inletzte
LoZeile = 1                                 ' erste Zeile in die was geschrieben werden  _
_
_
soll
If Cells(1, InI)  "" Then                 ' kein Inhalt in Zelle
StWert = Cells(1, InI)                  ' Zellinhalt auf die Variable schreiben
If Not Cells(1, InI).HasFormula Then    ' Eingabe ist keine Formel
If Len(StWert) > 50 Then        ' Zellinhalt länger als 50 Zeichen
Do                      ' Schleife für das Aufteilen
If InStrRev(StWert, " ", 50) > 0 Then
' erste Leerstelle von rechts bis
' 50. Stelle ermitteln und den
' Teil in die Zelle schreiben
Cells(LoZeile, InI) _
= Trim(Left(StWert, InStrRev(StWert, _
" ", 50)))
' restlichen Zellinhalt auf
' Variable schreiben
StWert = Mid(StWert, _
InStrRev(StWert, " ", 50) + 1)
Else
' keine Leerstelle gefunden,
' 50 Stellen in Zelle schreiben
Cells(LoZeile, InI) _
= Trim(Left(StWert, 50))
' restlichen Zellinhalt auf
' Variable schreiben
StWert = Mid(StWert, 51)
End If
' Spaltennummer um 1 erhöhen
LoZeile = LoZeile + 1
' Schleife verlassen falls Restzeichenkette
' kürzer als 50 Zeichen
Loop Until Len(StWert) 
Kann mir dabei bitte jemand helfen?
Beste Grüße webrollo

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Text in Zelle aufteilen u. untereinander schreiben
07.01.2016 23:45:13
Daniel
Hi
soweit ich weiss, gilt die Beschränkung auf 256 Zeichen nur wenn du Sheet.Copy ausführst.
kopierst du die Zellinhalte mit .Copy und fügst mit .PasteSpecial ein, müssten auch grössere Texte übertragen werden.
(es spricht ja auch nichts dagegen, erst mit Sheets.Copy das ganze blatt zu kopieren und dann mit Copy/PasteSpecial nochmal die betroffenen Spalten).
Ansonsten probier mal diesen Code, welcher den Text in Blöcke zu maximal 256 Zeichen aufteilt udn dabei zum nächsten Leerzeichen oder Zeilenumbruch zurück geht.
untereinanderliegende Zellen werden nach unten verschoben.
die Spalte in der das ganze ausgeführt wird, ist in der Variablen "Spalte" abgelegt und kann dort einfach geändert werden.
Sub TextAufteilen()
Dim txt As String
Dim arr
Dim z As Long
Dim Pos As Long
Dim Zähler As Long
Dim Spalte As Long
Spalte = 5
arr = ActiveSheet.UsedRange.Columns(Spalte).Value
For z = 1 To UBound(arr, 1)
txt = txt & arr(z, 1) & "|"
Next
Do
Pos = Pos + 1
Zähler = Zähler + 1
If Mid(txt, Pos, 1) = "|" Then Zähler = 0
If Zähler = 256 Then
Do
If Mid(txt, Pos, 1) = " " Or Mid(txt, Pos, 1) = vbLf Then
Mid(txt, Pos, 1) = "|"
Zähler = 0
Exit Do
End If
Pos = Pos - 1
Loop
End If
Loop While Pos 
Gruss Daniel

Anzeige
Text aufteilen Code überarbeitet
08.01.2016 01:36:57
Daniel
hier der Code nochmal optimiert und erweitert für den Fall, dass länger als 256 Zeichen kein Leerzeichen vorkommt bei dem getrennt werden kann. In diesem Fall wird der Text nach 256 Zeichen an dieser Stelle getrennt.

Sub TextAufteilen()
Dim txt As String
Dim arr
Dim z As Long
Dim Pos As Long
Dim Zähler As Long
Dim Spalte As Long
Dim TrennPos As Long
Spalte = 5
arr = ActiveSheet.UsedRange.Columns(Spalte).Value
For z = 1 To UBound(arr, 1)
txt = txt & arr(z, 1) & "|"
Next
Do
Pos = Pos + 1
Zähler = Zähler + 1
Select Case Mid(txt, Pos, 1)
Case "|": Zähler = 0
Case " ", vbLf: TrennPos = Pos
Case Else
End Select
If Zähler = 256 Then
Zähler = 0
If TrennPos = 0 Then
txt = Left(txt, Pos) & "|" & Mid(txt, Pos + 1)
Else
Mid(txt, TrennPos, 1) = "|"
Pos = TrennPos
TrennPos = 0
End If
End If
Loop While Pos 

Anzeige
Wenn Abfrage
08.01.2016 13:10:35
webrollo
Hallo Daniel,
zunächst mal vielen lieben Dank für das schnelle beantworten
und das schön kurze Script -aber-
da nur in Spalte 5 eine Zelle unter der mit dem vielen Text hinzugefügt wird
und die Spalten A,B und C (1,2 und 3) stehen bleiben, stehen nach dem Script
Texte an falscher Stelle. Auf den ersten Blick gar nicht zu erkennen, aber da es
sich um ein fortlaufendes Ereignisprotokoll handelt -übel.
Es müsste wenn, eine ganze Reihe unter der Zelle mit dem Text erzeugt werden,
die dann die darunter liegenden Zellen, nach unten drängt und je nach Menge des Textes
können es auch 2 und mehr Zeilen sein.
Hast du dazu eine Lösung? Wäre klasse!
Beste Grüße webrollo

Anzeige
AW: Wenn Abfrage
08.01.2016 16:12:30
Daniel
dann probiers mal so
das Makro Test starten.
die zu prüfende Spalte und die Anzahl der Zeichen im Text sind in konstanten hinterlegt.
das ganze läuft im aktiven Blatt.
wobei ich aber immer noch der meinung bin, dass beim kopieren und Einfügen der Werte aus Spalte E auch mehr als 256 Zeichen übertragen werden müssten.
Sub test()
Const Spalte As Long = 5
Const MaxZeichen As Long = 256
Dim Zeile As Long
Dim TeilTexte
For Zeile = Cells(Rows.Count, Spalte).End(xlUp).Row To 1 Step -1
With Cells(Zeile, Spalte)
If Len(.Value) > MaxZeichen Then
TeilTexte = TextAufteilen(.Value, MaxZeichen)
.Offset(1, 0).Resize(UBound(TeilTexte), 1).EntireRow.Insert
.Resize(UBound(TeilTexte) + 1, 1).Value = WorksheetFunction.Transpose(TeilTexte)
End If
End With
Next
End Sub
Function TextAufteilen(txt As String, MaxZeichen As Long) As Variant
Dim Pos As Long
Dim Zähler As Long
Dim Spalte As Long
Dim TrennPos As Long
Do
Pos = Pos + 1
Zähler = Zähler + 1
Select Case Mid(txt, Pos, 1)
Case " ", vbLf: TrennPos = Pos
Case Else
End Select
If Zähler = MaxZeichen Then
Zähler = 0
If TrennPos = 0 Then
txt = Left(txt, Pos) & "|" & Mid(txt, Pos + 1)
Else
Mid(txt, TrennPos, 1) = "|"
Pos = TrennPos
TrennPos = 0
End If
End If
Loop While Pos 
gruss Daniel

Anzeige
Danke
08.01.2016 18:20:02
webrollo
Guten Abend Daniel,
vielen Dank, die letzte Version sieht sehr "gesund" aus,
kann ich aber erst morgen ausgiebig testen.
Beste Grüße webrollo

361 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige