Thema: Zellen in neuem Tabellenblatt kopieren | Herbers Excel-Forum

Hallo zusammen,
folgendes Problem:
In meiner ersten Spalte sind x Zellen, wobei eine Zelle mehrere Wörter (durch Semikolon getrennt) enthalten können (siehe Überschrift Ausgangssituation).
Diese müssen in einem neuen Tabellenblatt nun untereinander kopiert werden (siehe Überschrift 1. Schritt (Text in Zeilen)).
Im letzten Schritt muss noch der Inhalt der Spalten B-F in das neue Tabellenblatt kopiert werden (s. Überschrift 2. Schritt: so soll's aussehen)
Ausgangssituation
Titel 1 Titel 2 Titel 3 Titel 4 Titel 5 Titel 6
barclays; apax; goldman karstadt hertie xxx xxx xxx
barclays obi kaufhof yyy yyy yyy
lehmann; abc; def hre kfw zzz zzz zzz
1. Schritt (Text in Zeilen)
Titel 1 Titel 2 Titel 3 Titel 4 Titel 5 Titel 6
barclays karstadt hertie xxx xxx xxx
apax
goldman
barclays obi kaufhof yyy yyy yyy
lehmann hre kfw zzz zzz zzz
abc
def
2. Schritt: so soll's aussehen
Titel 1 Titel 2 Titel 3 Titel 4 Titel 5 Titel 6
barclays karstadt hertie xxx xxx xxx
apax karstadt hertie xxx xxx xxx
goldman karstadt hertie xxx xxx xxx
barclays obi kaufhof yyy yyy yyy
lehmann hre kfw zzz zzz zzz
abc hre kfw zzz zzz zzz
def hre kfw zzz zzz zzz
Habt ihr eine Idee, wie man dieses Problem lösen kann?
Hier mein Quellcode:

Sub Test_04()
Range("A3:F3").Select
Selection.Copy
Sheets("Tabelle2").Select
Range("B2").Select
ActiveSheet.Paste
Range("B3").Select
Sheets("Tabelle1").Select
Range("A4:A7").Select
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("I4"), DataType:=xlDelimited, TextQualifier:= _
xlSingleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
Range("I4:M4").Select
Selection.Copy
Sheets("Tabelle2").Select
Selection.PasteSpecial Paste:=xlPasteAll, operation:=xlNone, skipblanks:=False, Transpose:=  _
True
Sheets("Tabelle1").Select
Range("I4:M4").Select
Application.CutCopyMode = False
Selection.ClearContents
Range("B4:F4").Select
Selection.Copy
Sheets("Tabelle2").Select
Range("C3:C7").Select
Sheets("Tabelle1").Select
Range("A5").Select
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("I5"), DataType:=xlDelimited, TextQualifier:=  _
SingleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
Range("I5:M5").Select
Selection.Copy
Sheets("Tabelle2").Select
Range("B65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteAll, operation:=xlNone, skipblanks:=False, Transpose:= _
True
Sheets("Tabelle1").Select
Range("I5:M5").Select
Application.CutCopyMode = False
Selection.ClearContents
Range("B5:F5").Select
Selection.Copy
Sheets("Tabelle2").Select
Range("C6:C10").Select
ActiveSheet.Paste
Range("B65536").End(xlUp).Offset(1, 0).Select
Sheets("Tabelle1").Select
Range("A6").Select
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("I6"), DataType:=xlDelimited, TextQualifier:= _
xlSingleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
Range("I6:M6").Select
Selection.Copy
Sheets("Tabelle2").Select
Range("B65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteAll, operation:=xlNone, skipblanks:=False, Transpose:= _
True
Sheets("Tabelle1").Select
Application.CutCopyMode = False
Selection.ClearContents
Range("B6:F6").Select
Selection.Copy
Sheets("Tabelle2").Select
Range("C8:C12").Select
ActiveSheet.Paste
End Sub

Leider ist man mit dieser Lösung sehr unflexibel, da in einer Zelle 1-5 Wörter stehen können.

Hallo Ingo,
mit folgender Variante sollte es funktionieren.
Gruß
Franz

Sub Test()
Dim wks1 As Worksheet, wks2 As Worksheet, Zeile1 As Long, Zeile2 As Long
Dim Bereich As Range, arrSplit As Variant, intI As Long
Set wks1 = ActiveSheet 'Blatt mit den Ausgangsdaten
'Neues Tabellenblatt anlegen
Set wks2 = Worksheets.Add(After:=wks1)
Zeile2 = 1 'nach dieser Zeile werden die aufbereiteten Daten eingefügt
'Spaltentitel in Zieltabelle eintragen
wks2.Cells(Zeile2, 1) = "Feld01"
wks2.Cells(Zeile2, 2) = "Feld02"
wks2.Cells(Zeile2, 3) = "Feld03"
wks2.Cells(Zeile2, 4) = "Feld04"
wks2.Cells(Zeile2, 5) = "Feld05"
wks2.Cells(Zeile2, 6) = "Feld06"
Range("A2").Select
ActiveWindow.FreezePanes = True 'Fenster fixieren
With wks1
Application.ScreenUpdating = False
For Zeile1 = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
'Bereich Spalten B bis F in zeile merken
Set Bereich = .Range(.Cells(Zeile1, 2), .Cells(Zeile1, 6))
'Inhalt in Spalte A der Zeile am Semikolon splitten
arrSplit = Split(Expression:=.Cells(Zeile1, 1), Delimiter:=";")
For intI = LBound(arrSplit) To UBound(arrSplit)
'Zeilenzähler im Zielblatt erhöhen
Zeile2 = Zeile2 + 1
'Werte eintragen (inkl. Leerzeichen am Anfang/Ende löschen) /kopieren
wks2.Cells(Zeile2, 1).Value = Trim(arrSplit(intI))
Bereich.Copy Destination:=wks2.Cells(Zeile2, 2)
Next
Next
Application.ScreenUpdating = True
End With
End Sub

Hallo Franz,
es funktioniert. Super Lösung!
Vielen Dank!!!
Beste Grüße,
Ingo