Création d'un fichier Excel distinct pour chaque résultat de filtre

Question

J'ai une feuille de calcul que je veux diviser en feuilles séparées pour chaque département. Il y a plus que les départements affichés et je veux que les fichiers .xls soient sauvegardés avec le nom du département

Le champ du département est la colonne D.

-à-dire que je voudrais un fichier .xls pour chacun avec uniquement les enregistrements pour le département 1, département 2, et ainsi de suite.

Malheureusement, je ne parviens pas à poster une capture d'écran de la feuille de calcul car mon représentant n'est pas encore assez bon.

Quel code VBA utiliserais-je pour cela?

Answer 1

Cela devrait faire ce dont vous avez besoin. Si vous exécutez et de fournir une lettre de la colonne, il se basera sur cette colonne, sinon il sera renvoyé par défaut à D que vous avez spécifié:

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 

Cela va générer un classeur séparé dans le même dossier que le livre de travail que vous exécutez ceci depuis ... ou dans le chemin que vous fournissez.