如何根据 A 列中的单词将一张 excel 表的行导出到新的 excel 表中

Question

我有一个包含超过 8,000 行的工作表，每行都是 29 个单词中的 1 个作为 A 列中的标识符。我想编写一个 VBA 脚本来解析所有行，并按 A 列中的标识符对它们进行分组并将每个组导出到一个新的工作表中，并将每个工作表命名为其标识符

例如，如果这是我的数据：

Column A    Column B    Column C
   X          cat          blue
   Y          dog          red
   Z          bird         green
   Y          whale        yellow
   Z          tiger        black
   X          wolf         purple   

我想要名为 X 的工作表 1 的输出：

Column A    Column B    Column C
   X          cat          blue
   X          wolf         purple

我想要名为 Y 的工作表 2 的此输出：

Column A    Column B    Column C
   Y          dog          red
   Y          whale        yellow

还有名为 Z 的 Sheet 3 的输出：

Column A    Column B    Column C
   Z          bird        green
   Z          tiger       black

Answer 1

你可以使用Range对象的AutoFilter()方法，如下：

选项显式

Sub main()
    Dim helperCol As Range, cell As Range

    With Worksheets("Data") '<--| reference your relevant sheet (change "Data" to your actual sheet name)
        Set helperCol = .UsedRange.Resize(, 1).Offset(, .UsedRange.Columns.COUNT) '<--| set a "helper" range where to store unique identifiers
        With .Range("C1", .Cells(.Rows.COUNT, 1).End(xlUp).Offset(1)) '<-- reference its "data" range from cell "A1" to last not empty cell in column "C"
            helperCol.Value = .Resize(, 1).Value '<--| copy identifiers to "helper" range
            helperCol.RemoveDuplicates Columns:=1, Header:=xlYes '<--| remove duplicates in copied identifiers
            For Each cell In helperCol.Resize(helperCol.Rows.COUNT - 1).Offset(1).SpecialCells(xlCellTypeConstants) '<--| loop through unique identifiers, skipping header
                .AutoFilter Field:=1, Criteria1:=cell.Value  '<--| filter "data" on identifiers column with current (unique) identifier
                .SpecialCells(xlCellTypeVisible).Copy Destination:=GetOrCreateSheet(cell.Value).Range("A1") '<--| copy filtered data (skipping header) and paste it to corresponding sheet starting from its column "A" first not emtpy cell
            Next cell
        End With
        .AutoFilterMode = False '<--| show all rows back
        helperCol.ClearContents '<--| clear "helper" range
    End With
End Sub

Function GetOrCreateSheet(shtName As String) As Worksheet
    On Error Resume Next
    Set GetOrCreateSheet = Worksheets(shtName)
    If GetOrCreateSheet Is Nothing Then
        Set GetOrCreateSheet = Worksheets.Add
        GetOrCreateSheet.name = shtName
    Else
        GetOrCreateSheet.Cells.ClearContents
    End If
End Function

Answer 2

您在这里遇到了一些多步骤问题。到目前为止，您是否编写过任何代码？如果您遇到任何具体错误，请在此处发布，我们很乐意提供更具体的建议。

目前，我建议将您的问题分解为其组件功能。然后，您可以继续工作、寻求帮助并自行完成这些部分，最后将它们全部联系在一起。

推荐的分步方法：

第 1 步：循环遍历一个范围。

Some examples.

第 2 步：解析并保存结果。

A starting place for learning about VBA conditional statements.

A starting place for learning about VBA arrays.

第 3 步：添加和命名新工作表。

A previous Stack Overflow answer.

第 4 步：将存储的信息放到新工作表上。

If you're using the arrays approach, here's a previous Stack Overflow question regarding the Transpose function.

祝你好运！

Answer 3

如果您使用 Excel for Windows，您可以通过 ADO ODBC 访问 Jet/ACE SQL Engine 并运行 SQL 查询来实现需求。是的，您可以查询当前工作簿（上次保存的实例）：

Sub RunSQL()
    Dim conn As Object, rst As Object
    Dim strConnection As String, strSQL As String
    Dim i As Integer, fld As Object
    Dim WS As Worksheet, var As Variant

    Set conn = CreateObject("ADODB.Connection")
    Set rst = CreateObject("ADODB.Recordset")

    ' STRING CONNECTION (TWO VERSIONS)
'    strConnection = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _
'                      & "DBQ=C:\Path\To\Workbook.xlsm;"
    strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" _
                       & "Data Source='C:\Path\To\Workbook.xlsm';" _
                       & "Extended Properties=""Excel 8.0;HDR=YES;"";"
    ' OPEN DB CONNECTION
    conn.Open strConnection

    For Each var In Array("X", "Y", "Z")
        ' CREATE WORKSHEET
        Set WS = ActiveWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count))
        WS.Name = var

        ' SQL STATEMENT
        strSQL = " SELECT [Sheet1$].[Column A], [Sheet1$].[Column B]," _
                   & " [Sheet1$].[Column C]" _
                   & " FROM [Sheet1$]" _
                   & " WHERE [Sheet1$].[Column A] = '" & var & "';"
       ' OPEN RECORDSET
        rst.Open strSQL, conn

        ' COLUMN HEADERS
        WS.Range("A1").Activate
        For i = 1 To rst.Fields.Count
           WS.Cells(1, i) = rst.Fields(i - 1).Name
        Next i    
        ' DATA ROWS
         WS.Range("A2").CopyFromRecordset rst

         rst.Close
    Next var

    conn.Close
    Set rst = Nothing: Set conn = Nothing
End Sub