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