Makro zum teilen einer Tabelle

Hey liebe Excel-Kenner,
Mein Anliegen bezieht sich auf einen Datensatz den ich jeden Morgen bekomme.
Er hat maximal 2000 Zeilen, die Spalten A-L und in der ersten Zeile Überschriften für die jeweiligen Spalten.
Dieser Datensatz sollte nach Möglichkeit mit Hilfe eines VBA Codes in mehrere Tabellen (zu je 40 Zeilen) geteilt und auch seperat gespeichert werden (Beispiel: Ausgangsdatensatz 800 Zeilen - 20 resultierende Tabellen (Seite 1 - 20). Das Ganze am besten mit den jeweiligen Überschriften in jeder Tabelle. (Bespiel resultierende Tabelle 1 - Einträge 1-40 - Seite 1 usw.)
Desweiteren bräuchte ich einen anderen VBA Code der sich damit befasst in Zeile E Beträge die größer als 2000.00 sind zu filtern und die ganze Spalte in eine extra Tabelle zu kopieren. Auch hier vorzugsweise mit Überschriften. Auch diese Tabelle soll nach Möglichkeit wieder automatisch gespeichert werden (Name beispielsweise: große Beträge)
Ich bin für jede Hilfe dankbar.
Liebe Grüße
Josie

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Test() Dim Überschrift As Range Dim Bereich As Range Dim nTab As Worksheet Dim A As Long Application.ScreenUpdating = False With Tabelle1 Set Überschrift = .Rows(1) Set Bereich = .Range("2:41") For A = 2 To .UsedRange.Rows.Count Step 40 Set nTab = Worksheets.Add(, Worksheets(Sheets.Count)) Überschrift.Copy nTab.Range("A1") Bereich.Copy nTab.Range("A2") Set Bereich = Bereich.Offset(40, 0) Next A End With Application.ScreenUpdating = True End Sub

Option Explicit Sub Test() Dim Überschrift As Range Dim Bereich As Range Dim nTab As Worksheet Dim A As Long, i As Integer Dim NeuMappe As Workbook Dim Pfad As String With Application .StatusBar = "Dateien werden erstellt, bitte warten...!" .ScreenUpdating = False .DisplayAlerts = False Pfad = IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\") With Tabelle1 Set Überschrift = .Rows(1) Set Bereich = .Range("2:41") For A = 2 To .UsedRange.Rows.Count Step 40 Set nTab = Worksheets.Add(, Worksheets(Sheets.Count)) Überschrift.Copy nTab.Range("A1") Bereich.Copy nTab.Range("A2") nTab.Copy Set NeuMappe = ActiveWorkbook i = i + 1 NeuMappe.SaveAs Pfad & "Datei_" & i NeuMappe.Close False nTab.Delete Set Bereich = Bereich.Offset(40, 0) Next A End With .DisplayAlerts = True .ScreenUpdating = True .StatusBar = False End With End Sub

Hallo,
teste mal ob es nach deinen Vorstellungen funktioniert.

Option Explicit

Sub Test()
'Deklarierung 
Dim Überschrift As Range
Dim Bereich As Range
Dim nTab As Worksheet
Dim A As Long, i As Integer
Dim NeuMappe As Workbook
Dim Pfad As String, strDateiName As String

 
With Application
 .StatusBar = "Dateien werden erstellt, bitte warten...!"
 .ScreenUpdating = False
 .DisplayAlerts = False
Pfad = "C:\" 'Speicherpfad 
'aktueller Dateiname ohne Extension 
strDateiName = Left$(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".") - 1)
With Tabelle1 'Tabelle mit Daten 
    Set Überschrift = .Rows(1) 'ist Überschrift 
    Set Bereich = .Range("2:41") 'erster Bereich 40 Zeilen 
    
    'Schleife bis letzte Zeile in 40er Schritten 
    For A = 2 To .UsedRange.Rows.Count Step 40
     'neue Tabelle erstellen 
     Set nTab = Worksheets.Add(, Worksheets(Sheets.Count))
      'Überschrift in Tabelle kopieren 
      Überschrift.Copy nTab.Range("A1")
      'Werte in Tabelle übertragen 
      Bereich.Copy nTab.Range("A2")
         'Tabelle in neue Mappe 
            nTab.Copy
         'neue Datei in Variable 
            Set NeuMappe = ActiveWorkbook
         'Zähler für Seitenindex 
            i = i + 1
         'Datei Speichern unter 
            NeuMappe.SaveAs Pfad & strDateiName & "_Seite" & i
         'neue Datei schließen 
            NeuMappe.Close False
         'Tabelle wieder löschen 
            nTab.Delete
         'nächte 40 Zeilen festlegen 
     Set Bereich = Bereich.Offset(40, 0)
    Next A
 
End With
 .DisplayAlerts = True
 .ScreenUpdating = True
 .StatusBar = False
End With
End Sub

Gruß Tino

www.VBA-Excel.de

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Makro zum teilen einer Tabelle

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread