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