New workbooks for divisions and worksheets for departments

[SpecialCase]

Say I have a workbook like this:

Div Dpt Revenue
AA 100 $474
AA 100 $327
AA 100 $244
AA 110 $505
AA 110 $390
AA 110 $133
AA 110 $598
BB 200 $175
BB 200 $621
BB 200 $149
BB 210 $402
BB 210 $631
BB 210 $102
BB 220 $327
BB 220 $117
CC 300 $148
CC 300 $121
CC 300 $552
CC 300 $446
CC 310 $766
CC 310 $620
CC 320 $203
CC 320 $312
CC 320 $177
CC 330 $227
CC 330 $272

I would like to automatically create new workbooks for the divisions and worksheets within them for the departments. Bonus is to have the worksheets named after the department it shows. Can't get this one figured out. Thanks.

 

[SpecialCase]

Solved the problem myself.

Sub CreateDivWorkbooksWithDptWSs()
Dim OWB As Workbook
Dim OWS As Worksheet
Dim NWB As Workbook
Dim NWS As Worksheet

Set OWB = ActiveWorkbook
Set OWS = ActiveSheet

FinalRow = OWS.Cells(Rows.Count, 1).End(xlUp).Row
FinalLoopRow = FinalRow + 1

With OWS
.Range("A2:C" & FinalRow).Select
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("A1:A" & FinalRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=Range("B1:B" & FinalRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
End With
With OWS.Sort
.SetRange Range("A1:C" & FinalRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

LastDivDpt = Cells(2, 1) & Cells(2, 2)
StartRow = 2

For i = 2 To FinalLoopRow

ThisDivDpt = OWS.Cells(i, 1) & OWS.Cells(i, 2)

If ThisDivDpt = LastDivDpt Then

'Do nothing

Else

LastRow = i - 1
RowCount = LastRow - StartRow + 1

Set NWB = Workbooks.Add(Template:=xlWBATWorksheet)
Set NWS = NWB.Worksheets(1)

OWS.Range("A1:C1").Copy Destination:=NWS.Cells(1, 1)

OWS.Range(OWS.Cells(StartRow, 1), OWS.Cells(LastRow, 3)).Copy _
Destination:=NWS.Cells(2, 1)

FN = LastDivDpt & ".xlsx"
FP = OWB.Path & Application.PathSeparator

NWB.SaveAs Filename:=FP & FN
NWB.Close SaveChanges:=False

LastDivDpt = ThisDivDpt
StartRow = I
End If

Next I

End Sub

 

[Fluff]

Another option

Sub SplitData()

   Dim Ws As Worksheet
   Dim Dic As Object
   Dim Cl As Range
   Dim v1 As String, v2 As String
   Dim Ky As Variant, K As Variant
   
   Set Dic = CreateObject("scripting.dictionary")
   Dic.comparemode = vbTextCompare
   Set Ws = ActiveSheet
Application.ScreenUpdating = False
   If Ws.AutoFilterMode Then Ws.AutoFilterMode = False
   For Each Cl In Ws.Range("A2", Ws.Range("A" & Rows.Count).End(xlUp))
      v1 = Cl.Value: v2 = Cl.Offset(, 1).Value
      If Not Dic.exists(v1) Then
         Dic.Add v1, CreateObject("scripting.dictionary")
         Dic(v1).Add v2, Nothing
      ElseIf Not Dic(v1).exists(v2) Then
         Dic(v1).Add v2, Nothing
      End If
   Next Cl
   For Each Ky In Dic.keys
      Workbooks.Add (1)
      For Each K In Dic(Ky)
      Sheets.Add.Name = K
         Ws.Range("A1").AutoFilter 1, Ky
         Ws.Range("A1").AutoFilter 2, K
         Ws.AutoFilter.Range.SpecialCells(xlVisible).Copy Range("A1")
      Next K
      Application.DisplayAlerts = False
      Sheets(Sheets.Count).Delete
      Application.DisplayAlerts = True
      ActiveWorkbook.SaveAs "[COLOR=#ff0000]C:\MrExcel\[/COLOR]" & Ky & ".xlsm", 52
      ActiveWorkbook.Close False
   Next Ky
   Ws.AutoFilterMode = False
End Sub

Change file path to suit

 

[SpecialCase]

Thank you very much, Fluff!

I did something with my macro, but it was not what I was actually trying to do. It created a separate workbook for each combination of division and department but your macro created a separate workbook for each division with a worksheet for each department.

Your macro did what I was trying to do.

 

[Fluff]

Glad to help & thanks for the feedback