Sub CreateCompanyWorkbooks()
Dim MyDirectory As String
Dim SourceCount As String
Dim Msg As Integer
SourceCount = Application.InputBox("Enter the # of source sheets:", Title:="Get Source Sheet Count", Type:=2)
If Not IsNumeric(SourceCount) Then
MsgBox "Invalid # of source sheets.", vbCritical
Exit Sub
End If
Msg = MsgBox("Are your source sheets named as consecutive integers (1, 2, ...)?", vbYesNo)
If Msg = vbYes Then
MyDirectory = Application.GetSaveAsFilename("Select directory to save new files", Title:="Get Directory")
MyDirectory = Left(MyDirectory, InStrRev(MyDirectory, "\"))
Application.ScreenUpdating = False
Call CreateCompanyWorksheets(SourceCount)
Call MoveSheets(MyDirectory)
Application.ScreenUpdating = True
Else
MsgBox "Please change your source sheet names."
End If
End Sub
Private Sub CreateCompanyWorksheets(SourceCount As String)
Dim CodeColumn As Integer
Dim HeaderRow As Integer
Dim StartRow As Long
Dim DataRange As Range, CodeRange As Range
Dim UniqueRange As Range, CountRange As Range
Dim c As Range, CopyRange As Range
Dim ws As Worksheet, sht As Object
Dim i As Integer, break As Integer
Application.ScreenUpdating = False
CodeColumn = 3 '<-- Set this equal to the column number for the Company Code
StartRow = 2 '<-- Set this equal to the row number of the first non-header row
For i = 1 To SourceCount
Set ws = Worksheets("" & i & "")
ws.Activate
' Create a sorted range to holding all worksheet data
Set DataRange = ws.UsedRange
DataRange.Sort Key1:=Cells(1, CodeColumn), Order1:=xlAscending, Header:=xlYes
' Create a range of all company codes
Set CodeRange = ws.Range(Cells(1, 3), Cells(Rows.Count, 3).End(xlUp))
' Create a range of the unique company codes
CodeRange.AdvancedFilter xlFilterCopy, CopyToRange:=Cells(1, ws.UsedRange.Columns.Count + 2), Unique:=True
Set UniqueRange = ws.Range(Cells(2, ws.UsedRange.Columns.Count), Cells(Rows.Count, ws.UsedRange.Columns.Count).End(xlUp))
' Create a range which contains the # of occurrences of each company code
Set CountRange = UniqueRange.Offset(0, 1)
CountRange.FormulaR1C1 = "=COUNTIF(" & CodeRange.Address(ReferenceStyle:=xlR1C1) & ", RC[-1])"
Set StartRange = DataRange.Range(Cells(StartRow, 1), Cells(StartRow, DataRange.Columns.Count))
' Loop through unique company codes and copy matching cells to self-titled worksheets
For Each c In UniqueRange.Cells
ws.Activate
Set EndRange = StartRange.Offset(CountRange.Cells(c.Row - 1, 1).Value - 1, 0)
Set CopyRange = Range(StartRange, EndRange)
break = 0
For Each sht In ActiveWorkbook.Sheets
' If a worksheet name matches the company code then
If CStr(c.Value) = sht.Name Then
' Copy the company codes to the appropriate sheet
CopyRange.Copy
sht.Activate
sht.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial
break = 1
Exit For
End If
Next sht
' If the worksheet does not already exist, add it to the workbook
If break <> 1 Then
Worksheets.Add.Name = c.Value
ws.Activate
' Copy header and appropriate company codes to new self-titled sheet
DataRange.Range(Cells(1, 1), Cells(1, DataRange.Columns.Count)).Copy
Worksheets("" & c.Value & "").Range("A1").PasteSpecial
CopyRange.Copy
Worksheets("" & c.Value & "").Range("A2").PasteSpecial
End If
' Move to the first uncopied line in the DataRange
Set StartRange = EndRange.Offset(1, 0)
Next c
' Delete added ranges from source sheets
UniqueRange.EntireColumn.Delete
CountRange.EntireColumn.Delete
Next i
End Sub
Private Sub MoveSheets(MyDirectory As String)
Dim ws As Worksheet
Dim MyName As String
Application.DisplayAlerts = False
' Moves each sheet in the workbook (excepting the source sheets) to a new workbook
For Each ws In ThisWorkbook.Worksheets
MyName = ws.Name
If MyName <> "1" And MyName <> "2" Then
ws.Move
ActiveWorkbook.SaveAs Filename:=MyDirectory & MyName
ActiveWorkbook.Close
End If
ThisWorkbook.Activate
Next ws
Application.DisplayAlerts = True
End Sub