VBA: create worksheets for unique entries

Question

I have a column of thousands of entries. However, there are only roughly 15 unique names in that column. I need create a worksheet for each of those unique names and copy their respective rows into said sheets.

Thanks for any help you can give.

Answer 1

Here is an approach that will use SQL to pull out each of the unique entries into separate ADODB.Recordsets .

My Data looks like:

ID  Field 1  Field 2  Field 3
1   A        B        C
2   A        B        C
3   A        B        C
4   A        B        C
5   A        B        C
...

And so on. I have up to ID 15, with the same Field1-3 values.

I'm using the code below to split up the data into recordsets, which have filtered the data on the distinct IDs on Sheet1. This approach is pretty quick, it is splitting up 36,000 records into 15 sheets in ~5 seconds on my machine.

Please note the below method is ok to use for local excel files, but using non-parameterized queries are vulnerable to SQL injection attacks.

Code

 Public Sub CreateSheets()
    On Error GoTo errhand:

    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Dim Conn            As Object
    Dim distinctRS      As Object
    Dim outputrs        As Object
    Dim ws              As Excel.Worksheet
    Dim i               As Long
    Dim connstr         As String

    'Make sure you save your Excel sheet before running. You may need to alter the connection strin
    'to connect to the right version of Excel
    'more information on different connections here --> https://www.connectionstrings.com/excel/
    connstr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & _
              ";Extended Properties='Excel 12.0 Macro;HDR=YES'"

    'The ID is the column name in the query below, you may need to change this to
    'be the name of YOUR column. Sheets must be reference in [] and suffixed with a '$'
    Const distinctSQL = "Select Distinct ID From [Sheet1$]"

    'Same thing as with distinctSQL, update the ID column name
    Const outputSQL = "Select * from [Sheet1$] Where ID = "

    Set Conn = CreateObject("ADODB.Connection")

    Conn.connectionstring = connstr
    Conn.Open

    Set distinctRS = CreateObject("ADODB.Recordset")
    Set outputrs = CreateObject("ADODB.Recordset")

    With distinctRS
        .Open distinctSQL, Conn

        Do Until .EOF

            '1 is adStateOpen
            If outputrs.State = 1 Then outputrs.Close

            outputrs.Open outputSQL & .Fields(0).Value, Conn

            Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            ws.Name = .Fields(0).Value

            'Add Headers
            For i = 0 To outputrs.Fields.Count - 1
                ws.Cells(1, i + 1).Value = outputrs.Fields(i).Name
            Next

            'Add the data from the recordset
            ws.Range("a2").CopyFromRecordset outputrs
            .movenext
        Loop

    End With

CleanExit:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Exit Sub

errhand:
    'Add error handling here

    Resume CleanExit
End Sub