Split Excel-Tabelle in mehrere Dateien basierend auf Spalte VBA
Haben Sie große Datenmengen auf Excel-Arbeitsblättern und müssen diese Arbeitsblätter auf mehrere Arbeitsblätter verteilen, basierend auf einigen Daten in einer Spalte? Diese sehr grundlegende Aufgabe ist aber zeitaufwändig.
Zum Beispiel habe ich diese Daten. Diese Daten haben eine Spalte mit dem Namen Datum, Verfasser und Titel. Die Writer-Spalte enthält den Namen des Writers des jeweiligen Titels. Ich möchte die Daten jedes Autors in separaten Blättern abrufen.
Um dies manuell zu tun, muss ich Folgendes tun:
-
Filtern Sie einen Namen. Kopieren Sie die gefilterten Daten. Fügen Sie ein Blatt hinzu. Fügen Sie die Daten ein. Benennen Sie das Blatt um. Wiederholen Sie alle obigen 5 Schritte für jeden.
In diesem Beispiel habe ich nur drei Namen. Stellen Sie sich vor, Sie hätten Hunderte von Namen.
Wie würden Sie Daten in verschiedene Blätter aufteilen? Es wird viel Zeit in Anspruch nehmen und Sie auch erschöpfen.
Führen Sie die folgenden Schritte aus, um den obigen Vorgang des Aufteilens von Blättern in mehrere Blätter zu automatisieren.
Drücken Sie Alt + F11. Dadurch wird der VB-Editor für Excel geöffnet. Ein neues Modul hinzufügen * Unter Code in Modul kopieren.
Sub SplitIntoSheets()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
ThisWorkbook.Activate
Sheet1.Activate
'clearing filter if any
On Error Resume Next
Sheet1.ShowAllData
On Error GoTo 0
Dim lsrClm As Long
Dim lstRow As Long
'counting last used row
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
Dim uniques As Range
Dim clm As String, clmNo As Long
On Error GoTo handler
clm = Application.InputBox("From which column you want create files" & vbCrLf & "E.g. A,B,C,AB,ZA etc.")
clmNo = Range(clm & "1").Column
Set uniques = Range(clm & "2:" & clm & lstRow)
'Calling Remove Duplicates to Get Unique Names
Set uniques = RemoveDuplicates(uniques)
Call CreateSheets(uniques, clmNo)
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.AlertBeforeOverwriting = True
.Calculation = xlCalculationAutomatic
End With
Sheet1.Activate
MsgBox "Well Done!"
Exit Sub
Data.ShowAllData
handler:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.AlertBeforeOverwriting = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Function RemoveDuplicates(uniques As Range) As Range
ThisWorkbook.Activate
Sheets.Add
On Error Resume Next
ActiveSheet.Name = "uniques"
Sheets("uniques").Activate
On Error GoTo 0
uniques.Copy
Cells(2, 1).Activate
ActiveCell.PasteSpecial xlPasteValues
Range("A1").Value = "uniques"
Dim lstRow As Long
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:A" & lstRow).Select
ActiveSheet.Range(Selection.Address).RemoveDuplicates Columns:=1, Header:=xlNo
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
Set RemoveDuplicates = Range("A2:A" & lstRow)
End Function
Sub CreateSheets(uniques As Range, clmNo As Long)
Dim lstClm As Long
Dim lstRow As Long
For Each unique In uniques
Sheet1.Activate
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
lstClm = Cells(1, Columns.Count).End(xlToLeft).Column
Dim dataSet As Range
Set dataSet = Range(Cells(1, 1), Cells(lstRow, lstClm))
dataSet.AutoFilter field:=clmNo, Criteria1:=unique.Value
lstRow = Cells(Rows.Count, 1).End(xlUp).Row
lstClm = Cells(1, Columns.Count).End(xlToLeft).Column
Debug.Print lstRow; lstClm
Set dataSet = Range(Cells(1, 1), Cells(lstRow, lstClm))
dataSet.Copy
Sheets.Add
ActiveSheet.Name = unique.Value2
ActiveCell.PasteSpecial xlPasteAll
Next unique
End Sub
Wenn Sie die Prozedur SplitIntoSheets () ausführen, wird das Blatt basierend auf der angegebenen Spalte in mehrere Blätter unterteilt. Sie können eine Schaltfläche auf dem Blatt hinzufügen und dieses Makro diesem zuweisen.
Wie es funktioniert
Der obige Code hat zwei Prozeduren und eine Funktion. Zwei Prozeduren sind SplitIntoSheets (), CreateSheets (eindeutig als Bereich, clmNo so lang) und eine Funktion ist RemoveDuplicates (eindeutig als Bereich) als Bereich. Die erste Prozedur ist SplitIntoSheets (). Dies ist das Hauptverfahren. Diese Prozedur legt die Variablen und RemoveDuplicates fest, um eindeutige Namen aus der angegebenen Spalte abzurufen, und übergibt diese Namen dann zum Erstellen von Arbeitsblättern an CreateSheets.
RemoveDuplicates verwendet ein Argument, nämlich den Bereich, der den Namen enthält.
Entfernt Duplikate von ihnen und gibt ein Bereichsobjekt zurück, das eindeutige Namen enthält.
Jetzt wird CreateSheets aufgerufen. Es braucht zwei Argumente. Erstens die eindeutigen Namen und zweitens die Spalten-Nr. von dem wir es fitler Daten werden. Jetzt nimmt CreateSheets jeden Namen von Unikaten und filtert die angegebene Spaltennummer nach jedem Namen. Kopiert die gefilterten Daten, fügt ein Blatt hinzu und fügt die Daten dort ein. Und Ihre Daten werden in Sekundenschnelle in verschiedene Blätter aufgeteilt.
Sie können die Datei hier herunterladen.
In Blätter teilen
So verwenden Sie die Datei:
-
Kopieren Sie Ihre Daten auf Sheet1. Stellen Sie sicher, dass es von A1 beginnt.
Klicken Sie auf die Schaltfläche In Blätter teilen * Geben Sie den Spaltenbuchstaben ein, von dem Sie teilen möchten. OK klicken.
-
Sie sehen eine solche Eingabeaufforderung. Ihr Blatt ist geteilt.
Ich hoffe, der Artikel über das Aufteilen von Daten in separate Blätter war für Sie hilfreich. Wenn Sie Zweifel an dieser oder einer anderen Funktion von Excel haben, können Sie diese gerne im Kommentarbereich unten erfragen.