Zellen in neuem Tabellenblatt kopieren
Ingo
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.