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

Question

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

没有错误的是下面那个。它正在创建不同的工作表，并根据原始工作表中 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