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

我很惊讶，我一直没有find解决scheme在网上浮动。 有几个类似的问题，但涉及更复杂的部分。 这是真的准备工作簿。 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) 

从这里使用quicksortalgorithm得到

 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