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

将所有工作表重命名为Sheet1 ColA中每个单元格的值

1 个答案: