AW: Liste auf Blätter aufteilen
08.11.2006 20:29:26
Erich
Hallo Ralph,
wofür brauchst du das denn - eine so schöne Tabelle auf Blätter aufteilen?
Wenn auf jedem Blatt nur der Inhalt einer Zeile stehen soll, dann gilt Makro "EineSpalte".
Eine Alternative wäre: Überschriften in Spalte A, Werte in Spalte B. Das macht Makro "ZweiSpalten".
Option Explicit
Sub EineSpalte()
Dim wks As Worksheet, lngLast As Long, lngZ As Long
' 1. Blatt muss Quellblatt sein
Set wks = Worksheets(1)
If Left(wks.Name, 7) = "Tabelle" Then wks.Name = "Quell-" & wks.Name
lngLast = wks.Cells(Rows.Count, 1).End(xlUp).Row ' Anzahl Zeilen in Quelle
For lngZ = 1 To lngLast ' Schleife über Zeilen
' Application.DisplayAlerts = False
On Error Resume Next ' kein Fehler, falls zu löschendes Blatt nicht ex.
Worksheets("Tabelle" & lngZ).Delete ' lösche evtl vorhandenes Blatt
On Error GoTo 0 ' Fehlerbehandlung wieder normal
' Application.DisplayAlerts = True
Sheets.Add(after:=Worksheets(lngZ)).Name = "Tabelle" & lngZ
wks.Rows(lngZ).Copy
Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
'oder
' Cells(1, 1).PasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Range("A1").Select
Columns(1).AutoFit
Next lngZ
Application.CutCopyMode = False
wks.Select
End Sub
Sub ZweiSpalten()
Dim wks As Worksheet, lngLast As Long, lngZ As Long
' 1. Blatt muss Quellblatt sein
Set wks = Worksheets(1)
If Left(wks.Name, 7) = "Tabelle" Then wks.Name = "Quell-" & wks.Name
lngLast = wks.Cells(Rows.Count, 1).End(xlUp).Row ' Anzahl Zeilen in Quelle
For lngZ = 2 To lngLast ' Schleife über Zeilen
' Application.DisplayAlerts = False
On Error Resume Next ' kein Fehler, falls zu löschendes Blatt nicht ex.
Worksheets("Tabelle" & lngZ).Delete ' lösche evtl vorhandenes Blatt
On Error GoTo 0 ' Fehlerbehandlung wieder normal
' Application.DisplayAlerts = True
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "Tabelle" & lngZ
wks.Rows(1).Copy
Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, _
Transpose:=True
wks.Rows(lngZ).Copy
Cells(1, 2).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, _
Transpose:=True
Range("A1").Select
Columns(2).AutoFit
Next lngZ
Application.CutCopyMode = False
wks.Select
End Sub
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort