Sub CopyToNewSheetsByGroup_2()
Dim strName As String, i As Integer
Dim UsedRng As Range, Rng As Range, FRng As Range, R As Range, c As Range, sh As Worksheet
Dim HdrBoo As Boolean, HdrMsg As Variant, HdrRng As Range
Dim StartTime As Date, TmpSh As Worksheet, TmpRng As Range
Dim GroupIDs As String, ShName As String
intResponse = MsgBox("This macro will create a worksheet for each unique group identifier" & vbCrLf & _
"in the user-selected column. This may take a while to" & vbCrLf & _
"process if there are a lot of groups. Continue?", vbOKCancel, "Separate By Groups")
If intResponse = vbOK Then
'Get used range for the sort
Set UsedRng = ActiveSheet.UsedRange
'Ask for column to base your search. If no range is selected procedure stopped
On Error Resume Next 'set Rng will error if no range selected
Set Rng = Application.InputBox("Select column with Group ID's" & vbCrLf _
& "Column must not contain Formulas.", "Pick a Column", , , , , , 8)
If Rng Is Nothing Or Rng.Columns.Count > 1 Then 'exit if cancel was pressed or more than 1 column is selected
MsgBox "Operation cancelled"
Exit Sub
End If
'Ask if theres a header row. By default HdrBoo is false.
HdrMsg = MsgBox("Do you have a header row?" & vbLf & _
"Note: Must be the 1st row in worksheet", vbYesNo, "Header Row?")
If HdrMsg = vbYes Then
HdrBoo = True 'variable to indicate if a header is used
End If
'Start Timer
StartTime = Timer
'Turn off screen updating & calculation
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error GoTo errorhandler
'Filter unique values
ActiveSheet.Columns(Rng.Column).AdvancedFilter Action:=xlFilterInPlace, _
CriteriaRange:=Rng, Unique:=True
'Copy unique values to a temporary sheet
Set TmpSh = Worksheets.Add 'create temp sheet
Sheets(Rng.Parent.name).Activate 'return to original sheet
Set Rng = Range(Rng.End(xlUp), Rng.End(xlDown)) 'make sure entire column is selected
Rng.Copy TmpSh.Range("a1") 'copy unique items to temporary sheet
TmpSh.Activate
MyCount = TmpSh.Range([A1], [A1].End(xlDown)).Rows.Count
If MyCount > 21 Then
intResponse = MsgBox("There are more than 20 different groups." & vbCrLf & vbCrLf & _
"This could take a while. Continue?", vbOKCancel, "Separate by Groups")
If intResponse = vbCancel Then GoTo errorhandler
End If
'Set ranges for header (if applicable) and unique values
TmpSh.Activate
If HdrBoo = True Then
Set HdrRng = Range("A1") '1st row in the range is the header
Set TmpRng = Range("A2:A" & Range("A1").End(xlDown).Row) 'unique values
Else
Set TmpRng = Range("A1:A" & Range("A1").End(xlDown).Row) 'unique values
End If
Sheets(Rng.Parent.name).Activate 'return to original sheet
Application.CutCopyMode = False 'turn off copy mode
ActiveSheet.ShowAllData 'remove Advanced Filter
Set FRng = Range(Rng.End(xlUp), Rng.End(xlDown)) 'Set Full Range column for later use
'Loop through each unique value to copy row to target in respective new sheets
For Each c In TmpRng
i = i + 1 'counter for sheet name
Set sh = Worksheets.Add(After:=Sheets(Sheets.Count)) 'add a new sheet & name it
ShName = TrimExcelSheetName(c.Value)
If SheetExists(ShName) Then
sh.name = ShName & Sheets.Count
Else
sh.name = ShName 'name sheet as string and counter number
End If
'Assign counter variable for row number to copy to
'Also copy Header if True
If HdrBoo = True Then
cntr = Sheets(ShName).UsedRange.Rows.Count + 1
'copy header row to target sheet
Sheets(Rng.Parent.name).Rows("1:1").Copy Sheets(ShName).Range("A1")
Else
cntr = Sheets(ShName).UsedRange.Rows.Count
End If
For Each R In FRng
If R.Value = c Then
r2c = R.Row
Sheets(Rng.Parent.name).Rows(r2c & ":" & r2c).Copy Sheets(ShName).Range("A" & cntr)
cntr = cntr + 1 'increment counter row number
End If
Next R
sh.Cells.EntireColumn.autofit
Next c
'Turn back on screen updating & remove filter
Application.ScreenUpdating = True
Sheets(Rng.Parent.name).Activate 'return to original sheet
ActiveSheet.AutoFilterMode = False
'Delete Temporary sheet
Application.DisplayAlerts = False 'avoids delete confirmation message
TmpSh.Delete
Application.DisplayAlerts = True
'Display the elapsed time
MsgBox "The procedure took " & Format(Timer - StartTime, "00.00") & " seconds.", _
vbInformation, "Operation Successfully Completed"
End If
ActiveSheet.AutoFilterMode = False
errorhandler:
If Err <> 0 Then
MsgBox Err.Number & ": " & Err.Description, , "Error Occurred"
On Error GoTo 0
End If
Application.Calculation = xlCalculationAutomatic
End Sub
