CODEWITHSUNDEEP
vbaexcel
warasen
warasen

Reputation: 51

Rename all worksheets to the values of each cell in Sheet1 ColA

I'm surprised I haven’t been able to find the solution floating around online. There have been several similar questions asked but more complicated parts involved. This is really to prep the workbook. Sheet1 ColA has a list of section numbers. I need it rename the worksheets to each of the section numbers. They will need to stay in order and create more sheets if needed. Leaving exactly one sheet for every section number.

This is some code that I found but don't fully understand. It seems close and I just need to modify it to use ColA instead of the column with the header "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

Upvotes: 2

Views: 1712

Answers (1)

Nat
Nat

Reputation: 14295

This is how to rename the sheets

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

This is how to move a sheet. 

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

Using the quicksort algorithm from here you get

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

Upvotes: 2

Related Questions