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

Question

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

谢谢你提供的所有帮助。

Answer 1

这是一种使用SQL将每个唯一条目提取到单独的ADODB.Recordsets 。

我的数据如下：

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秒钟的时间内将36,000条记录分成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