Sub TopFolder()
Set myFolder = Application.FileDialog(msoFileDialogFolderPicker)
With myFolder
.Title = "Choose Folder"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Sub
End If
FolderSelected = .SelectedItems(1)
End With
Worksheets("Run").Range("C9").Value = FolderSelected
End Sub
Sub CreateGroups()
If Sheets("Run").Range("C9").Value = "" Then
MsgBox "Please browse to the top level folder before running macro."
Exit Sub
End If
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim thisWb, newWb As Workbook
Dim dRow, dEnd, fRow, groupCnt As Long
Dim path, newName As String
groupCnt = 0
dRow = 2
fRow = 2
dEnd = Sheets(2).UsedRange.Rows.Count
'Sort data by group
On Error Resume Next
Sheets(2).Range("A2:Z" & dEnd).Sort _
Key1:=Sheets(2).Range("A2"), Order1:=xlAscending, _
Key2:=Sheets(2).Range("C2"), Order2:=xlAscending, Header:=xlNo
Set thisWb = ActiveWorkbook
'Read through data, when Group changes, create folder and spreadsheet
Do While dRow <= dEnd
If dRow <> 2 And thisWb.Sheets(2).Cells(dRow, 1).Value <> thisWb.Sheets(2).Cells(dRow - 1, 1).Value Then
'Create folder
path = thisWb.Sheets("Run").Range("C9").Value & "\" & thisWb.Sheets(2).Cells(fRow, 1).Value
If Len(Dir(path, vbDirectory)) = 0 Then
MkDir path
End If
'Create new file
Set newWb = Workbooks.Add
newName = path & "\" & thisWb.Sheets(2).Cells(fRow, 1).Value & ".xlsx"
'Delete File
On Error Resume Next
Kill newName
'Copy headings to Sheet1
thisWb.Sheets(2).Range("C1:H1").Copy
With newWb.Sheets(1).Range("A1")
.Cells(1).PasteSpecial xlPasteColumnWidths
.Cells(1).PasteSpecial xlPasteValues
.Cells(1).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
'Copy values to Sheet1
thisWb.Sheets(2).Range("C" & fRow & ":H" & dRow - 1).Copy
With newWb.Sheets(1).Range("A2")
.Cells(1).PasteSpecial xlPasteColumnWidths
.Cells(1).PasteSpecial xlPasteValues
.Cells(1).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
newWb.Sheets(1).Range("A1").Select
With newWb
.SaveAs newName
End With
newWb.Close
groupCnt = groupCnt + 1
fRow = dRow
End If
dRow = dRow + 1
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox groupCnt & " groups were processed."
End Sub