vba - 将所有工作表重命名为 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)

使用 here 中的快速排序算法你得到

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