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

Question

I have a worksheet with over 8,000 rows and each one as 1 of 29 words as an identifier in column A. I would like to write a VBA script that will parse all of the rows, group them by the identifier in column A and export each group into a new work sheet and name each worksheet as its identifier

For example if this is my data:

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

I would like this output for Sheet 1 named X:

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

I would like this output for Sheet 2 named Y:

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

And this output for Sheet 3 named Z:

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

Answer 1

you could use AutoFilter() methods of Range object, as follows:

Option Explicit

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

You've got a bit of a multi-step problem here. Have you written up any code so far? If you've run into any specific errors, post them here and we'll gladly provide more specific advice.

For now, I would recommend breaking up your problem into its component features. You can then proceed to work on, seek help with, and complete each of these parts on their own and tie them all together at the end.

A recommended step-by-step approach:

Step 1: Looping through a range.

Some examples.

Step 2: Parse and save the results.

A starting place for learning about VBA conditional statements.

A starting place for learning about VBA arrays.

Step 3: Adding and naming a new worksheet.

A previous Stack Overflow answer.

Step 4: Placing your stored information onto your new sheet.

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

Good luck!

Answer 3

Should you use Excel for Windows, you can access the Jet/ACE SQL Engine via ADO ODBC and run SQL queries to achieve needs. And yes, you can query the current workbook (last saved instance):

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