根据一列（Excel，VBA）的内容在多个工作表中拆分数据

我需要将现有的Excel工作表拆分为不同的工作表。 具体来说，我需要创build新的工作表，以便A列（原始工作表中）的单元格中具有相同内容的所有行放在同一个工作表中。 我在网上find了不同的VBA代码，但是他们都没有为我工作。

没有错误的是下面的一个。 它创build了不同的工作表，根据原始工作表中列A中包含的信息对其进行命名，但不会拆分行（所有工作表都以相同的数据结束）。

能否请你帮忙？ 谢谢！

Sub parse_data() Dim lr As Long Dim ws As Worksheet Dim vcol, i As Integer Dim icol As Long Dim myarr As Variant Dim title As String Dim titlerow As Integer vcol = 1 Set ws = Sheets("Sheet1") lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row title = "A1:C1" titlerow = ws.Range(title).Cells(1).Row icol = ws.Columns.Count ws.Cells(1, icol) = "Unique" For i = 2 To lr On Error Resume Next If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol) End If Next myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants)) ws.Columns(icol).Clear For i = 2 To UBound(myarr) ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & "" If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & "" Else Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count) End If ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1") Sheets(myarr(i) & "").Columns.AutoFit Next ws.AutoFilterMode = False ws.Activate End Sub 

Answer 1

这将做到这一点。 请注意，如果这些表已经存在，将会删除这些表，如果您不希望发生这种情况，请随时调整。 另外，如果在列A中有Excel不接受作为工作表名称（例如“/”）的值

 Option Explicit Sub split_worksheet() 'This will create a new sheet for each unique value in Column A of Sheet1. 'Note: you will need to delete everything besides sheet1. 'Set up looping variables Dim sheet1 As Worksheet Set sheet1 = ThisWorkbook.Sheets("Sheet1") Dim sheet1_rows As Integer sheet1_rows = sheet1.UsedRange.Rows.Count Dim sheet1_cols As Integer sheet1_cols = sheet1.UsedRange.Columns.Count 'Loop through column A, adding sheets as we go Dim i As Integer, colA_value As String Dim rng1 As Range, rng2 As Range Dim sheetDict As Object Set sheetDict = CreateObject("scripting.dictionary") For i = 2 To sheet1_rows colA_value = sheet1.Cells(i, 1).Value If Not sheetDict.Exists(colA_value) Then 'Delete the sheets if they already exist on error resume next thisworkbook.sheets(colA_value).delete on error goto 0 'Handle blank rows in A If colA_value = "" Then colA_value = "BLANK" 'create the new sheet ThisWorkbook.Worksheets.Add().Name = colA_value 'Write the header row ThisWorkbook.Sheets(colA_value).Range(Cells(1, 1).Address + ":" + Cells(1, sheet1_cols).Address).Value = sheet1.Range(Cells(1, 1).Address + ":" + Cells(1, sheet1_cols).Address).Value 'add target row to our dictionary sheetDict.Add colA_value, 2 'copy the range from sheet1 to the new sheet Set rng1 = sheet1.Range(Cells(i, 1).Address + ":" + Cells(i, sheet1_cols).Address) Set rng2 = ThisWorkbook.Sheets(colA_value).Range(Cells(sheetDict.Item(colA_value), 1).Address + ":" + Cells(sheetDict.Item(colA_value), sheet1_cols).Address) rng2.Value = rng1.Value 'Add a row to the sheetDict sheetDict.Item(colA_value) = sheetDict.Item(colA_value) + 1 Else 'copy the range from sheet1 to the new sheet 'Debug.Print sheetDict.Item(colA_value) Set rng1 = sheet1.Range(Cells(i, 1).Address + ":" + Cells(i, sheet1_cols).Address) Set rng2 = ThisWorkbook.Sheets(colA_value).Range(Cells(sheetDict.Item(colA_value), 1).Address + ":" + Cells(sheetDict.Item(colA_value), sheet1_cols).Address) rng2.Value = rng1.Value 'Add a row to the sheetDict sheetDict.Item(colA_value) = sheetDict.Item(colA_value) + 1 'Debug.Print colA_value, sheetDict.Items(colA_value) End If 'sheetDict.exists columnA Next i 'Garbage clean Set sheet1 = Nothing Set sheetDict = Nothing Set rng1 = Nothing Set rng2 = Nothing End Sub