PDA

Vollständige Version anzeigen : Tabelle aufteilen


LutzBö
20.07.2012, 14:11
Hallo,

ich bin ein ziemlicher Anfänger was VBA angeht. Aller Anfang ist halt schwer..
Nun stehe ich vor folgendem Problem:

Ich habe eine Tabelle, die indiziert ist.
Ich möchte nun alle Zeilen die mit 1.0, 1.1 etc indiziert sind in ein neues Tabellenblatt kopieren. Dieses soll automatisch auch sinnvoll benannt werden.
Darauf sollen alle Zeilen, die mit 2.0, 2.1 etc indiziert sind in ein weiteres Tabellenblatt kopiert werden... und so weiter.

Außerdem möchte ich den Code regelmäßig ausführen und brauche deswegen eine Prüfung, ob Tabellenblätter (z.B. Aufgabenbereich 1) bereits vorhanden sind. Diese sollen dann überschrieben werden.

Ich habe schon viel rumgesucht und ausprobiert und so einigermaßen läuft es. Aber nun bin ich an einem Punkt an dem ich nicht weiterkomme.


So weit bin ich jetzt.



Private Sub Filtern_2()
Dim kb As Range
Dim WS As Worksheet
Dim z As Integer 'Zähler AutoFilter

Set kb = ActiveSheet.UsedRange

For z = 1 To 3
z = z
Worksheets("Test").Activate
Worksheets("Test").UsedRange.AutoFilter
Worksheets("Test").UsedRange.AutoFilter 7, z
kb.Copy

For Each WS In Worksheets
If WS.Name = Worksheets("Test").UsedRange.SpecialCells(xlCellTypeVisible).Cells(2, 2) Then
WS.Activate
With kb
ActiveSheet.Paste
End With
Exit For
Else
Worksheets.Add after:=Worksheets(ActiveWorkbook.Worksheets.Count)
ActiveSheet.Name = Worksheets("Test").UsedRange.SpecialCells(xlCellTypeVisible).Cells(2, 2)
End If

Next WS

Next z
End Sub


Die Testtabelle häng ich auch mal an.
Entschuldigt, wenn das alles etwas wüst sein sollte. Bin wie gesagt Anfänger.
Freu mich auf Unterstützung und bin allen jetzt schon dankbar.

Liebe Grüße,
Lutz

Peter9
20.07.2012, 21:56
Hallo Lutz,

Ich habe mal dein Script geändert schau mal damit müsste es gehn

Option Explicit

Sub Filtern_2()
Dim kb As Range
Dim WS As Worksheet
Dim z As Integer 'Zähler AutoFilter
Dim i As Integer 'Zähler Name
Dim bExists As Boolean
Set kb = ActiveSheet.UsedRange
Application.ScreenUpdating = False
For z = 1 To 3
z = z
Worksheets("Test").Activate
Worksheets("Test").UsedRange.AutoFilter
Worksheets("Test").UsedRange.AutoFilter 7, z
kb.Copy

bExists = False
' Testen ob's ein Sheet mit dem Namen
' "Aufgabenbereich " & 1, 2, 3 gibt und ...
For i = 1 To Sheets.Count
If Sheets(i).Name = ("Aufgabenbereich " & z) Then
bExists = True: Exit For
End If
Next i

If bExists Then
' ... wenn ja: Daten einfühgen
Sheets("Aufgabenbereich " & z).Paste
Else
' ... wenn nein: TabellenBlatt erstellen einen Name vergeben und Daten einfügen.
' Beep
Worksheets.Add after:=Worksheets(ActiveWorkbook.Worksheets.Count)
Sheets(ActiveSheet.Name).Name = "Aufgabenbereich " & z 'Worksheets("Test").UsedRange.SpecialCells(xlCellTypeVisible).Cells(2, 2)
Sheets("Aufgabenbereich " & z).Paste
End If
Next z
' ... wenn fertig: Selection aufheben und Filter auf alle stellen
Worksheets("Test").Activate
ActiveSheet.Range("$A$1:$I$32").AutoFilter Field:=7
Application.ScreenUpdating = True
End Sub

EarlFred
21.07.2012, 06:54
Hallo Lutz,

oder schau mal hier:
http://www.ms-office-forum.de/forum/showpost.php?p=1446924&postcount=8

Grüße
EarlFred