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

Question

I would need to split an existing Excel worksheet into different ones. Specifically, I need the new worksheets to be created so that all the rows that have the same content in the cell in column A (in the original worksheet) are put in the same worksheet. I have found different VBA codes online, but none of them seem to work for me.

The one that doesn't have bug is the one below. It's creating different worksheets, naming them based on the info contained in column A in the original worksheet, but it's not splitting the rows (all the worksheets end up with the same data).

Could you please help? Thanks!

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

This will do it. Note that this will delete the sheets if they already exist, feel free to tweak if you don't want that to happen. Also, it will trip up if in Column A you have values that Excel won't accept as a sheet name (eg "/")

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