VBA：按某些规则拆分工作表

Question

我需要VBA帮助，它将根据A行中的值拆分当前工作表 Test1 。

Test1 工作表的格式为：

现在，我需要将工作表 Test1 拆分为两个（或更多）工作表，其中将包含以1.1和1.4开头的所有行（此值将是相同的规则，但数字不同）。

因此，在运行VBA代码后，将创建工作表 Test1-1 （绿色区域），其中包含以1.1开头的所有数据：

1.1
1.1.1
1.1.2
1.1.3

第二张工作表 Test1-2 （红色区域），以1.4开头：

1.4
1.4.1
1.4.2

创建原点后，可以删除 Test1 工作表。

您能给我帮助还是指导，我没有任何线索/想法来实现这一目标。

Answer 1

使用以下代码，输出将是：

两张纸

：

1. Test1-1
2. Test1-4

如果要获得此输出：

1. Test1-1
2. Test1-2

您应该：

1. 根据第一列对数据进行排序
2. 创建另一个具有初始值1的变量，并且每次Sheetname更改值而不是使用Sheetname变量时，请使用新变量。

指南：

1. 排序：

   Option Explicit
   
   Sub Sort()
   
       Dim LR As Long
   
       With ThisWorkbook.Worksheets("Test1")
   
           LR = .Cells(.Rows.Count, "A").End(xlUp).Row
   
       End With
   
   ThisWorkbook.Worksheets("Test1").Sort.SortFields.Clear
   ThisWorkbook.Worksheets("Test1").Sort.SortFields.Add2 Key:=Range("A1"), _
       SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
   With ActiveWorkbook.Worksheets("Test1").Sort
       .SetRange Range("A2:D" & LR)
       .Header = xlNo
       .MatchCase = False
       .Orientation = xlTopToBottom
       .SortMethod = xlPinYin
       .Apply
   End With
   
   End Sub
   

2. 新变量

来自：ActiveWorkbook.Worksheets（“ Test1-”＆SheetName）

收件人：ActiveWorkbook.Worksheets（“ Test1-”＆NewVariable）

尝试：

Option Explicit

Sub test()

    Dim LR As Long
    Dim LRN As Long
    Dim i As Long
    Dim SheetName As String
    Dim wsTest As Worksheet
    Dim wsNew As Worksheet

    With ThisWorkbook.Worksheets("Test1")

        LR = .Cells(.Rows.Count, "A").End(xlUp).Row

    End With

    For i = LR To 1 Step -1

        With ThisWorkbook.Worksheets("Test1")

            SheetName = Mid(.Range("A" & i), InStr(1, .Range("A" & i).Value, ".") + 1, 1)

        End With

        Set wsTest = Nothing
        On Error Resume Next
        Set wsTest = ActiveWorkbook.Worksheets("Test1-" & SheetName)
        On Error GoTo 0

        If wsTest Is Nothing Then
            Worksheets.Add.Name = "Test1-" & SheetName
        End If

        With ActiveWorkbook.Worksheets("Test1-" & SheetName)

            LRN = .Cells(.Rows.Count, "A").End(xlUp).Row

        End With

        ThisWorkbook.Worksheets("Test1").Range("A" & i & ":D" & i).Cut ActiveWorkbook.Worksheets("Test1-" & SheetName).Range("A" & LRN + 1)

    Next i

    Application.DisplayAlerts = False
        ThisWorkbook.Worksheets("Test1").Delete
    Application.DisplayAlerts = True

End Sub