フィルタ結果ごとに別々のExcelファイルを作成する

Question

私は部門ごとに別々のスプレッドシートに分割したいスプレッドシートを持っていますが、そこにはさらに多くの部門があり、それぞれの.xlsファイルを部門名私は上の部門1、部門2のための唯一の記録とそれぞれの.xlsファイルが好き、と考えすなわち

部門フィールドは、列D.

です。

私の担当者はまだ十分ではないため、残念ながらスプレッドシートのスクリーンショットを投稿できません。

これを行うにはどのような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 

これは、ワークブックあなたと同じフォルダ内の別のワークブックを生成します。 ...またはあなたが提供するパスでこれを実行してください。