VBA: разделить лист по определенному правилу

Question

Мне нужна помощь с VBA, которая разделит текущий лист Test1 в зависимости от значений из строк A.

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, используйте новую переменную.

Указания для:

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