Makro zum teilen einer Tabelle

Josefiene · 2008-11-04T18:33:00+00:00

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

Hallo,
ok. wie wäre es hiermit?
Die Dateien werden im Ordner der der Datei erstellt.
Modul Modul1

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

Gruß Tino

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

Forumthread: Makro zum teilen einer Tabelle

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Infobox / Tutorial

Makro zum Teilen einer Excel-Tabelle

Schritt-für-Schritt-Anleitung

Häufige Fehler und Lösungen

Alternative Methoden

Praktische Beispiele

Tipps für Profis

FAQ: Häufige Fragen

Beliebteste Forumthreads (12 Monate)