Question

我有一个包含超过8,000行的工作表，每一行都是29个单词中的一个，作为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

我希望Sheet 2的输出名为Y：

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

此表3的输出名为Z：

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引擎并运行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

如何根据A列中的单词将一个Excel工作表的行导出到新的Excel工作表中

3 个答案: