Erstellung Tabellenblätter abh von Spaltenanzahl

Hallo liebes Forum,
habe bereits im Archiv (auch anderer Foren gesucht), aber nicht das Richtige gefunden. Ich möchte über die Anzahl gefüllter Spalten, welche variabel ist, ein Tabellenblatt auf mehrere Blätter aufteilen, wobei je Blatt drei gefüllte Spalten erscheinen sollen.
Im Prinzip in der Art:
Anzahl Spalten (ab Spalte F) geteilt durch 3 = Anzahl neu zu erstellender Blätter
Zur Ermittlung der Anzahl kann die Zeile 8 genutzt werden.
Zur Tabelle:
Die Spalten A:E beinhalten Zeilenbeschriftung, Summe etc., sind also fix.
Die Spalten ab F sind in der Anzahl Variabel.
Viele Zellen weisen Bezüge, auch auf andere Tabellenblätter auf, daher können keine Spalten gelöscht werden oder so.
Meine bisherige Lösung:
Ich kopiere das Ursprungstabellenblatt entsprechend obiger Formel (zurzeit manuell) und blende dann jeweils die nicht interessierenden Spalten aus. Natürlich habe ich hierfür ein Makro, jedoch muss ich dieses jedes Mal an meine Tabelle manuell anpassen. Unten habe ich ein Makrobeispiel für eine Tabelle mit variablen Spalten von F bis Q, also 12 Spalten aufgeführt, die auf 4 Blätter verteilt werden sollen.
Mein Wunsch:
Da die Anzahl der Spalten auch mal 3stellig werden kann, sollte das Makro die Anzahl der variablen Spalten ermitteln, wobei der Wert aufgerundet werden muss (z.B. bei 10 Spalten brauche ich 4 Blätter, wenn max. 3 Spalten je Blatt aufgeführt werden sollen), dann die entsprechende Anzahl Tabellenblätter erstellen, und in diesen die Spalten ausblenden, die in dem jeweiligen Tabellenblatt nicht interessieren oder anders ausgedrückt: in Blatt (2) sollen die Spalten F/G/H, in Blatt (3) I/JK, etc zu sehen sein.

Sub Aufteilung_Tabelle()
' Aufteilung_Tabelle Makro
' Tastenkombination: Strg+t
'Kopieren der Tabellenblätter
Sheets("MErmittlung").Select
Sheets("MErmittlung").Copy After:=Sheets(1)
Sheets("MErmittlung").Select
Sheets("MErmittlung").Copy After:=Sheets(2)
Sheets("MErmittlung").Select
Sheets("MErmittlung").Copy After:=Sheets(3)
Sheets("MErmittlung").Select
Sheets("MErmittlung").Copy After:=Sheets(4)
'entsprechende Spalten im jeweiligen Tabellenblatt ausblenden, Spalten A:E sind fest
Sheets("MErmittlung (2)").Select
Columns("I:Q").Select
Selection.EntireColumn.Hidden = True
Sheets("MErmittlung (3)").Select
Range("F:H,L:Q").Select
Selection.EntireColumn.Hidden = True
Sheets("MErmittlung (4)").Select
Range("F:K,O:Q").Select
Selection.EntireColumn.Hidden = True
Sheets("MErmittlung (5)").Select
Columns("F:N").Select
Selection.EntireColumn.Hidden = True
End Sub

Anbei eine stark vereinfachte Beispieltabelle.
https://www.herber.de/bbs/user/70886.xls
Kann mir hierbei jemand helfen?
Mit freundlichen Grüßen
Tobias

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub TabellePro3SpaltenSplitten() Dim wsMErmittlung As Worksheet, wsNeu As Worksheet Dim lngS As Long Set wsMErmittlung = Worksheets("MErmittlung") 'Schleife von 6 bis letzte Spalte der Zeile 8 in 3er Schritten For lngS = 6 To Cells(8, Columns.Count).End(xlToLeft).Column Step 3 Set wsNeu = Sheets.Add(after:=Sheets(Sheets.Count)) 'Neues Blatt am Ende wsMErmittlung.Range("A:E").Copy wsNeu.[A1] 'Spalten A:E kopieren wsMErmittlung.Columns(lngS).Resize(, 3).Copy wsNeu.[F1] Next MsgBox "Fertig !" End Sub

Sub aufteilen() Dim i As Integer Application.ScreenUpdating = False For i = 1 To Application.RoundUp((Sheets("ermittlung").Cells(8, Columns.Count).End(xlToLeft). _ Column - 5) / 3, 0) Sheets("ermittlung").Copy after:=Sheets(Sheets.Count) With ActiveSheet .Columns.Hidden = True .Columns("A:E").Hidden = False .Columns((i - 1) * 3 + 6).Resize(, 3).Hidden = False Application.Goto .Cells(1, 1), True End With Next i End Sub

Hallo nochmal,
insbesondere NoNet und Rudi,
besteht die Möglichkeit, in dem Makro von Rudi noch einzufügen, dass vor Erstellung der Tabellenblätter bereits erstellte Tabellenblätter gelöscht werden? Habe nämlich (dummerweise) bei 95 Spalten und damit 32 neu erstellten Tabellenblättern das Makro zweimal ausgeführt - und jetzt 64 Blätter. Diese manuell zu markieren und löschen dauert :-)!
Es wäre also klasse, wenn das Makro im Vorfeld prüft, ob es diese Blätter bereits gibt oder so ähnlich, und wenn ja löscht.
Das Makro könnte auch ruhig separat sein, wenn dieses die Anzahl Blätter mit gleichem Namen (hier "MErmittlung" + lfd Zahl) löscht (aber nicht die Ursprungstabelle!!).
Für Hilfe wäre ich wieder sehr dankbar.
MfG
Tobias

Sub aufteilen() Dim i As Integer Application.ScreenUpdating = False LoescheSheets "Ermittlung*(*)" For i = 1 To Application.RoundUp((Sheets("ermittlung").Cells(8, Columns.Count).End(xlToLeft). _ _ Column - 5) / 3, 0) Sheets("ermittlung").Copy after:=Sheets(Sheets.Count) With ActiveSheet .Columns.Hidden = True .Columns("A:E").Hidden = False .Columns((i - 1) * 3 + 6).Resize(, 3).Hidden = False Application.Goto .Cells(1, 1), True End With Next i End Sub

Sub LoescheSheets(strSuch As String) Dim wks As Worksheet For Each wks In Worksheets If wks.Name Like strSuch Then Application.DisplayAlerts = False wks.Delete Application.DisplayAlerts = True End If Next End Sub

Beliebteste Forumthreads (12 Monate)

Erstellung Tabellenblätter abh von Spaltenanzahl

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread