Copy rows based on cell to new sheet


Well-known Member
Dec 18, 2002
Office Version
  1. 365
  1. Windows
The master sheet contains 9,000 rows. They are broken down into different classifications based on the value in column A. I would like to be able to copy all rows that have the same classification to a new sheet without having to copy and paste. Could this be done using a macro?

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.


Active Member
Sep 21, 2005
I have this beauty that I found somewhere!

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
        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
            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, _
                Application.Intersect(Rng, UsedRng).AutoFilter Field:=1, Criteria1:=HdrRng.Value, Operator:=xlOr, _
                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
                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
            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
        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
    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
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
Upvote 0

Forum statistics

Latest member

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back