Sub CopyToNewSheetsByGroup()
Dim strName As String, i As Integer
Dim UsedRng As Range, Rng 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", "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
Rng.Cells(1, 1).Select
'Loop through each unique value to filter target column then copy
'to respective new sheets
For Each c In TmpRng
If HdrBoo = True Then
' MsgBox Application.Intersect(Rng, UsedRng).Address
Application.Intersect(Rng, UsedRng).AutoFilter Field:=1, Criteria1:=HdrRng.Value, Operator:=xlOr, _
Criteria2:=c.Value
Application.Intersect(Rng, UsedRng).AutoFilter Field:=1, Criteria1:=HdrRng.Value, Operator:=xlOr, _
Criteria2:=c.Value
Else
Application.Intersect(Rng, UsedRng).AutoFilter Field:=1, Criteria1:=c.Value
Application.Intersect(Rng, UsedRng).AutoFilter Field:=1, Criteria1:=c.Value
End If
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
Rng.CurrentRegion.Copy sh.Cells(1, 1)
' ActiveSheet.SpecialCells(xlCellTypeVisible).EntireRow.Copy Sh.Cells(1, 1) 'copy entire row to new sheet
sh.Cells.EntireColumn.AutoFit
If sh.UsedRange.Rows.Count > 1 And HdrBoo = False Then
sh.Rows("1:1").Delete 'cant prevent header copying over so delete it
End If
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
' End If
' End If
errorhandler:
If Err <> 0 Then
MsgBox Err.Number & ": " & Err.Description, , "Error Occurred"
On Error GoTo 0
End If
Application.Calculation = xlCalculationAutomatic
End Sub
Function SheetExists(SheetName As String) As Boolean
' returns TRUE if the sheet exists in the active workbook
SheetExists = False
On Error GoTo NoSuchSheet
If Len(Sheets(SheetName).Name) > 0 Then
SheetExists = True
Exit Function
End If
NoSuchSheet:
On Error GoTo 0
End Function
Function TrimExcelSheetName(ByVal strSheetName As String)
'Function TrimExcelSheetName(ByVal strSheetName As String) As String
' Replaces characters in strSheetName that are
' not allowed by Excel in a sheet name.
' Truncates length of strSheetName to bytSheetNameLen.
' 2000-12-07. Gustav Brock, Cactus Data ApS, Copenhagen
On Error Resume Next
Const cstrInValidChars As String = ".\/:*?[]"
Const cstrReplaceChar As String * 1 = "-"
Const cbytWordLen As Byte = 31
Dim bytLen As Byte
Dim bytPos As Byte
Dim strChar As String
Dim strTrim As String
bytLen = Len(Left(strSheetName, cbytWordLen))
For bytPos = 1 To bytLen Step 1
strChar = Mid(strSheetName, bytPos, 1)
If InStr(cstrInValidChars, strChar) > 0 Then
strChar = cstrReplaceChar
End If
strTrim = strTrim & strChar
Next bytPos
TrimExcelSheetName = strTrim
End Function
