Создание отдельного файла excel для каждого результата фильтра

Question

У меня есть электронная таблица, которую я хочу разделить на отдельные таблицы для каждого отдела, там больше, чем показано в департаментах, и я хочу, чтобы файлы .xls для каждого сохранялись с именем отдела

поле отдел колонка D.

т.е. я хотел бы файл .xls для каждого только с записями для отдела 1, отдел 2, и так далее.

К сожалению, я не могу опубликовать скриншот таблицы, так как мой представитель еще недостаточно хорош.

Какой код VBA я использовал бы для этого?

Answer 1

Это должно делать то, что вам нужно. Если вы запустите его и обеспечить буквы столбца, он будет основывать его на этой колонке, в противном случае он будет по умолчанию D, как было указано:

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 

Это создаст отдельную книгу в той же папке, что и трудовой книжки вы запустите это с ... или на пути, который вы предоставляете.