Переименуйте все рабочие таблицы в значения каждой ячейки в Sheet1 ColA

Question

Я удивлен, что мне не удалось найти решение, распространяющееся по сети. Было задано несколько похожих вопросов, но были задействованы более сложные части. Это действительно для подготовки рабочей тетради. Sheet1 ColA имеет список номеров разделов. Мне нужно, чтобы переименовать рабочие листы для каждого номера раздела. Им нужно будет оставаться в порядке и создавать больше листов, если это необходимо. Оставляя ровно один лист для каждого номера секции.

Это код, который я нашел, но не до конца понял. Это кажется близким, и мне просто нужно изменить его, чтобы использовать ColA вместо столбца с заголовком «Last_Name».

Sub MakeSectionSheets()

Dim rLNColumn As Range
Dim rCell As Range
Dim sh As Worksheet 
Dim shDest As Worksheet 
Dim rNext As Range 

    Const sNUMB As String = "Last_Name"

    Set sh = ThisWorkbook.Sheets("Sheet1")
    Set rLNColumn = sh.UsedRange.Find(sNUMB, , xlValues, xlWhole)

    'Make sure you found something 
    If Not rLNColumn Is Nothing Then
        'Go through each cell in the column 
        For Each rCell In Intersect(rLNColumn.EntireColumn, sh.UsedRange).Cells 
            'skip the header and empty cells 
            If Not IsEmpty(rCell.Value) And rCell.Address <> rLNColumn.Address Then
                'see if a sheet already exists 
                On Error Resume Next
                    Set shDest = sh.Parent.Sheets(rCell.Value)
                On Error GoTo 0

                'if it doesn't exist, make it
                If shDest Is Nothing Then
                    Set shDest = sh.Parent.Worksheets.Add
                    shDest.Name = rCell.Value
                End If

                'Find the next available row
                Set rNext = shDest.Cells(shDest.Rows.count, 1).End(xlUp).Offset(1, 0)

                'Copy and paste
                Intersect(rCell.EntireRow, sh.UsedRange).Copy rNext

                'reset the destination sheet
                Set shDest = Nothing
            End If
        Next rCell
    End If

End Sub

Answer 1

Это как переименовать листы

Dim oWorkSheet As Worksheet

    For Each oWorkSheet In Sheets
        If Len(oWorkSheet.Cells(1, 1).Value) > 0 Then
            oWorkSheet.Name = oWorkSheet.Cells(1, 1)
        End If
    Next

Это как переместить лист.

    Sheets(1).Move Before:=Sheets(2)

Используя алгоритм быстрой сортировки из здесь вы получите

Public Sub QuickSortSheets()
    QuickSort 1, Sheets.Count
End Sub

Private Sub QuickSort(ByVal LB As Long, ByVal UB As Long)
    Dim P1 As Long, P2 As Long, Ref As String, TEMP As String

    P1 = LB
    P2 = UB
    Ref = Sheets((P1 + P2) / 2).Name

    Do
        Do While (Sheets(P1).Name < Ref)
            P1 = P1 + 1
        Loop

        Do While (Sheets(P2).Name > Ref)
            P2 = P2 - 1
        Loop

        If P1 <= P2 Then
            TEMP = Sheets(P1).Name
            Sheets(P2).Move Before:=Sheets(TEMP)
            Sheets(TEMP).Move After:=Sheets(P2 - 1)

            P1 = P1 + 1
            P2 = P2 - 1
        End If
    Loop Until (P1 > P2)

    If LB < P2 Then Call QuickSort(LB, P2)
    If P1 < UB Then Call QuickSort(P1, UB)
End Sub