Excel - VBA - Tabelle aufteilen in gleich große Teile

Question

Hallo!

ich stehe vor einer scheinbar endlos langen Tabelle.

Zur weiteren Verarbeitung hätte ich diese gerne in kleinere Teile aufgeteilt.

Ein Beginn des Makros habe ich schon, indem ich die wichtigsten Parameter ermittle und festlege.

Wie viel Spalten, Zeilen und wie groß soll ein Bereich sein, sind festgelegt, bzw. ermittelt.

Bitte um Hilfe, möchte die Teile als neues Blatt in die vorhandene Datei kopieren.

Die Kopfzeile ist fix in Zeile 1

Sub TabelleAufteilen()
Dim lzz, lzs, size As Long
lzs = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
lzz = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
size = InputBox("Wie viele Zeilen soll ein Teil enthalten?")

End Sub

Danke für eure Mühe, ich blicke nicht durch!

Gruß

Answer 1

Hallo,

hier mal ein Vorschlag:

Sub TabelleAufteilen()
Dim lzz As Long
Dim lzs As Long
Dim d As Long
Dim s As Long
Dim az As Long
Dim size As Long
Dim lngZaehler As Long
Dim arrDaten As Variant

lzs = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
lzz = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
size = InputBox("Wie viele Zeilen soll ein Teil enthalten?")

'vorhandene Daten in Array einlesen
arrDaten = Range(Cells(1, 1), Cells(lzz, lzs))

'Anzahl der notwendigen Tabellen ermitteln - ohne Überschrift
az = WorksheetFunction.RoundUp((lzz - 1) / size, 0)

'Zähler auf 1 setzen
lngZaehler = 1

'Falls Anzahl 0, dann Makro beenden
If az = 0 Then
  MsgBox "Fehler! Keine Daten vorhanden!", 16, "Abbruch des Makros"
  Exit Sub
End If

'nun zusätzliche Tabellenblätter erstellen
For i = 1 To az
 'Neues Blatt wird am Ende eingefügt
  Worksheets.Add After:=Worksheets(Worksheets.Count)
 With ActiveSheet
   'Neues Blatt benennen
   .Name = "Teiltabelle " & i
   'Überschriften in 1. Zeile schreiben
   For s = 1 To lzs
    .Cells(1, s) = arrDaten(1, s)
   Next s
   'Daten in neue Teiltabelle schreiben
   For d = 1 To size
     lngZaehler = lngZaehler + 1
     'nur Ausführen, solange Daten im Array vorhanden sind
     If lngZaehler <= UBound(arrDaten, 1) Then
       For s = 1 To lzs
         .Cells(d + 1, s) = arrDaten(lngZaehler, s)
       Next s
     End If
     Next d
  End With
Next i

End Sub

Gruß

M.O.

Answer 2

WOW, Danke!

funktioniert perfekt!

Ich danke dir für die Hilfe, du hast gar keine Ahnung wie viel graue Haare mir das bereitet hat :-)

Danke und liebe Grüße