VBA：为唯一条目创建工作表

我有一列成千上万的条目。然而，该列中只有大约15个唯一的名称。我需要为每个唯一的名称创建一个工作表，并将它们各自的行复制到所述工作表中

---

感谢您提供的帮助。

这里有一种方法，可以使用SQL将每个唯一的条目提取到单独的

ADODB.recordset

中

我的数据如下所示：

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
...

等等。我最多有ID 15，具有相同的Field1-3值

我使用下面的代码将数据分割成记录集，这些记录集过滤了Sheet1上不同ID上的数据。这种方法非常快，在我的机器上，它能在5秒内将36000条记录拆分成15张纸

请注意，以下方法可以用于本地excel文件，但使用非参数化查询容易受到SQL注入攻击

代码

 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