Code To Create New Worksheets And Copy Rows By Column A


Well-known Member
Jan 24, 2011
Office Version
  1. 365
  1. Windows
I have a workbook with data in column A. I need a code please that will create a new worksheet for each different number in column A. But this is only by the letters preceding the numbers. The data will be like below.

Excel 2010

So with the numbers above a sheet would be created and called 'BLS' and the entire row for each of these would be copied to that WS (including the headers in row one for each sheet). Another sheet will be created and called 'FP' and the entire row for each FP prefix copied across, the same with 'MS' and so on..

There may be some numbers without any letters as a prefix, these can be ignored.


Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.
Thanks dmt32. I have tried running it but its not responding. The data has several hundred thousand rows. Also will this code split by letter prefix, otherwise it will try creating sheets for 1000s of different numbers?

edit. I escaped from the code and it is trying to create a sheet for every different number in column A which is not what I want.
Last edited:
Upvote 0
The solution creates a list of unique records from selected column & then filters all matching records to a worksheet with same name.

If you want to copy those records that match a prefix part then solution may be able to be modified but I am time limited at moment I will, unless another here offers a solution, have a look when I can.

Upvote 0
If you have not found a solution then try this update to my code:

Discard previous code & Copy ALL codes below to a standard module.

Option Explicit
Sub FilterData()
'DMT32 Dec 2016
    Dim ws1Master As Worksheet, wsNew As Worksheet, wsFilter As Worksheet
    Dim Datarng As Range, FilterRange As Range, objRange As Range
    Dim rowcount As Long
    Dim colcount As Integer, FilterCol As Integer, FilterRow As Long
    Dim SheetName As String, msg As String
    Dim Prefix As Boolean

'master sheet
    Set ws1Master = ActiveSheet

'select the Column you are filtering
    On Error Resume Next
    Set objRange = Application.InputBox("Select Field Name To Filter", "Range Input", , , , , , 8)
    On Error GoTo 0
    If objRange Is Nothing Then
        Exit Sub
    ElseIf objRange.Columns.Count > 1 Then
        GoTo top
    End If

    FilterCol = objRange.Column
    FilterRow = objRange.Row

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    On Error GoTo progend

'add filter sheet
    Set wsFilter = Sheets.Add
    With ws1Master
        .Unprotect Password:=""  'add password if needed
        rowcount = .Cells(.Rows.Count, FilterCol).End(xlUp).Row
        colcount = .Cells(FilterRow, .Columns.Count).End(xlToLeft).Column

        If FilterCol > colcount Then
            Err.Raise 65000, "", "FilterCol Setting Is Outside Data Range.", "", 0
        End If

        Set Datarng = .Range(.Cells(FilterRow, 1), .Cells(rowcount, colcount))
        'extract Unique values from FilterCol
        .Range(.Cells(FilterRow, FilterCol), .Cells(rowcount, FilterCol)).AdvancedFilter _
                      Action:=xlFilterCopy, CopyToRange:=wsFilter.Range("A1"), Unique:=True
        rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row
'set Criteria
        wsFilter.Range("B1").Value = wsFilter.Range("A1").Value
'filter by prefix chars only
        Prefix = FilterByPrefix(sh:=wsFilter)

        For Each FilterRange In wsFilter.Range("A2:A" & rowcount)
            'check for blank cell in range
            If Len(FilterRange.Value) > 0 Then
'add the FilterRange to criteria
                wsFilter.Range("B2").Value = FilterRange.Value
'get sheet name
                SheetName = IIf(Prefix, Left(FilterRange.Value, Len(FilterRange.Value) - 1), Left(FilterRange.Value, 31))
'check if Filter sheet exists
                On Error Resume Next
                 Set wsNew = Worksheets(SheetName)
                    If wsNew Is Nothing Then
'add new sheet
                        Set wsNew = Sheets.Add(after:=Worksheets(Worksheets.Count))
                        wsNew.Name = SheetName
'clear existing data
                    End If
                On Error GoTo progend
'copy filtered data
                Datarng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsFilter.Range("B1:B2"), _
                                       CopyToRange:=wsNew.Range("A1"), Unique:=False
'fit data to columns
            End If
'clear from memory
            Set wsNew = Nothing
    End With

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    If Err > 0 Then MsgBox (Error(Err)), 16, "Error"
End Sub

Function FilterByPrefix(ByVal sh As Object) As Boolean
'DMT32 Dec 2016
    Dim i As Integer
    Dim msg As VbMsgBoxResult
    Dim LastRow As Long
    msg = MsgBox("Are You Filtering By Prefix?", 292, "Prefix Filter")
    If msg = 7 Then Exit Function
    LastRow = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
    For i = 2 To LastRow
        With sh.Cells(i, 1)
            .Value = Left(.Value, GetPrefix(.Value))
'add wild card
            If Len(.Value) > 0 Then .Value = .Value & "*"
        End With
        Next i
'xl2007 >
        sh.Range("A1:A" & LastRow).RemoveDuplicates Columns:=1, Header:=xlNo
        FilterByPrefix = True
End Function

Public Function GetPrefix(ByVal Value As String) As Integer
'DMT32 Dec 2016
'locate Pos of Numeric Value
    For GetPrefix = 1 To Len(Value)
        If Mid(Value, GetPrefix, 1) Like "#" Then GetPrefix = GetPrefix - 1: Exit Function
End Function

When run, you will first be asked to select the range you want to filter - you will then be asked if you are filtering values with a Prefix, select Yes.

Hopefully, this will do what you are seeking but is not fully tested but should give you something to work with.

I have assumed that you are using Excel 2007 or newer if not, some further additions will be required.

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