Hallo,
ich bin neu in VBA und habe gleich mal eine Frage :)
Meine Aufgabenstellung ist folgende.
wir haben mehrere Excel Tabellen in welchen viele Zellen existieren, die mehrere Zeichenfolgen haben.
Meine Aufgabe ist es diese großen Zellen zu löschen und die Zeichenketten in diesen Zellen in kleinere Zellen zu schreiben, d.h. dass jede Zeichenkette der großen Zelle in eine kleine (also normale Excel-Zelle) geschrieben wird.
Dies möchte ich gerne mit einem Makro lösen, da es doch sehr viel Arbeit beinhaltet.
D.h. ich möchte ein Makro, welches die Zeichenkette der großen Zelle liest, neue leere Zellen einfügt, und die einzelnen Zeichenketten, welche durch ein chr(10) getrennt sind, einzeln in die neuen Zellen schreibt.
Ich bin so weit gekommen, dass ich die Zeichenkette trennen und auch in neue Zellen untereinander schreiben kann, jedoch überschreibt er mir die unteren Zellen. Wenn ich neue Zellen einfüge, dann fügt er mir neue Zellen zwar ein, aber nicht die getrennten Zeichenketten. D.h. das Makro macht entweder das eine oder das andere:)
Könnt ihr mit bitte helfen. Hier der Quellcode:
Sub trenne_Zellen()
'große Zelle trennen, Inhalt in neue, kleine Zellen schreiben
'Variablen deklarieren
Dim lngZ As Long
Dim strTeilstring() As String
Dim strTrennzeichen As String
'Vorgaben definieren
Set wsakt = ThisWorkbook.Sheets("Redaktion") 'sollte aktives Blatt sein / active.sheet
lngZ = 17 'Startzeile; muss in jedem Blatt festgelegt werden // markierte Zelle bearbeiten z.B. range.selection
strTrennzeichen = Chr(10) 'Trennzeichen festlegen; müsste bei uns ein Zeilenumbruch sein chr(10)
'Durchlaufen aller Datenzeilen // soll nur die aktuelle markierte Zelle bearbeiten
For x = 17 To 18
'Teilstring am Zeilenumbruch auslesen
strTeilstring = Split(Trim(wsakt.Cells(lngZ, 2).Value), strTrennzeichen)
'Durchlaufen des gesamten Arrays einer Zelle vom ersten bis zum letzten Wert
For a = LBound(strTeilstring) To UBound(strTeilstring)
'Array-Elemente nacheinander eintragen
wsakt.Cells(lngZ, 2).Value = Trim(strTeilstring(a)) ' schreibt Werte in die vorgegebene Zelle
' Ziel: Original Zelle löschen und jeden String in eine neue Zelle schreiben
'Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
'ActiveSheet.Cells(x, 1).EntireRow.Insert
'ActiveSheet.Paste
'Zeilenzähler erhöhen
lngZ = lngZ + 1
'neue Zeile einfügen
'ActiveSheet.Cells(17, 1).EntireRow.Insert 'fügt neue leere Zelle ein; so erst einmal richtig aber: die neue Zelle muss befüllt werden.
Next a
Next x
End Sub
Vielen Dank schon mal!
|