Erstellen einer separaten Excel-Datei für jedes Filterergebnis

Question

Ich habe eine Tabelle, die ich in separate Tabellen für jede Abteilung trennen soll. Es gibt mehr als die Abteilungen angezeigt und ich möchte die .xls-Dateien für jede mit dem Abteilungsnamen gespeichert werden

Die Abteilung Feld Spalte D.

dh ich eine .xls-Datei für jede nur mit den Aufzeichnungen für die Abteilung 1, Abteilung 2, und so weiter möchte.

Leider kann ich keinen Screenshot der Tabelle posten, da mein Rep ist noch nicht gut genug.

Welcher VBA-Code würde ich verwenden, um dies zu tun?

Answer 1

Dies sollte tun, was Sie brauchen. Wenn Sie es ausführen und einen Spaltenbuchstaben bieten wird es auf dieser Spalte stützen, sonst wird es zu D Standard wie angegeben:

Sub SplitWorkbook(Optional colLetter As String, Optional SavePath As String) 
If colLetter = "" Then colLetter = "D" 
Dim lastValue As String 
Dim hasHeader As Boolean 
Dim wb As Workbook 
Dim c As Range 
Dim currentRow As Long 
hasHeader = True 'Indicate true or false depending on if sheet has header row. 

If SavePath = "" Then SavePath = ThisWorkbook.Path 
'Sort the workbook. 
ThisWorkbook.Worksheets(1).Sort.SortFields.Add Key:=Range(colLetter & ":" & colLetter), _ 
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal 
With ThisWorkbook.Worksheets(1).Sort 
    .SetRange Cells 
    If hasHeader Then ' Was a header indicated? 
     .Header = xlYes 
    Else 
     .Header = xlNo 
    End If 
    .MatchCase = False 
    .Orientation = xlTopToBottom 
    .SortMethod = xlPinYin 
    .Apply 
End With 

For Each c In ThisWorkbook.Sheets(1).Range("D:D") 
    If c.Value = "" Then Exit For 
    If c.Row = 1 And hasHeader Then 
    Else 
     If lastValue <> c.Value Then 
      If Not (wb Is Nothing) Then 
       wb.SaveAs SavePath & "\" & lastValue & ".xls" 
       wb.Close 
      End If 
      lastValue = c.Value 
      currentRow = 1 
      Set wb = Application.Workbooks.Add 
     End If 
     ThisWorkbook.Sheets(1).Rows(c.Row & ":" & c.Row).Copy 
     wb.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Select 
     wb.Sheets(1).Paste 

    End If 
Next 
If Not (wb Is Nothing) Then 
    wb.SaveAs SavePath & "\" & lastValue & ".xls" 
    wb.Close 
End If 
End Sub 

Dies wird eine separate Arbeitsmappe im selben Ordner wie das Arbeitsbuch erzeugen Sie führe dies von ... oder in dem von dir angegebenen Weg aus.