如何根據列A中的單詞將一個Excel表的行導入到新的Excel表中

Question

我有一個工作表，其中有超過8000行，每個表中有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 

我想這個輸出名爲Ÿ第2頁：

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