Renaming sheets based on Cell value in another sheet

[Wizerd]

I am looking to rename certain worksheets based on a cell value (in B2) in an a worksheet (called 'Setup). The value in that cell is a number. I wanted to look for all only the tabs that start with 'Grpxx - othertext' and rename them to Grp(cell value). Basically looking to change the number in the sheet name to a new number.

 

[mehidy1437]

Change below code according to your requirement;

Sub SheetRenameAll()
Dim chkMsg As String, chkAns As Variant
    chkMsg = "This will rename all the sheets name based on the selected cell value, except the first sheet"
    chkAns = MsgBox(chkMsg, vbYesNo)
    Select Case chkAns
        Case vbYes
'--------------------------------------------------------------
'code here
'--------------------------------------------------------------

   Dim ws As Worksheet
   Dim rng1 As Range, rng2 As String
   Set rng1 = Application.InputBox("Select a cell", "Cell", , , , , , 8)
   rng2 = rng1.Address(0, 0)

   For Each ws In Worksheets
      If ws.Index <> 1 Then
       ws.Name = Split(ws.Range(rng2).Value, " (")(0)
      End If
   Next ws

'--------------------------------------------------------------
'code here
'--------------------------------------------------------------

Done:
Exit Sub
'-----------------------------------------------------------------
    Case vbNo
        GoTo Quit:
    End Select
Quit:

End Sub

 

[Wizerd]

Thanks for the quick response. I ran it as is to start and get a Subscript out of range

 

[GWteB]

Provided the Grpxxx part of the sheet name is followed by a space and those xxx is a numeric representation, the code below is likely to do what you want.

Sub Wizerd()

    Const PREFIX As String = "Grp"

    Dim oWs     As Worksheet
    Dim Fmt     As String
    Dim Rp      As String
    Dim Nr      As Long
    Dim Pos     As Long
    Dim Pnr     As Variant

    Pnr = ThisWorkbook.Sheets("Setup").Range("B2").Value
    Pos = Len(PREFIX) + 1

    For Each oWs In ThisWorkbook.Worksheets
        With oWs
            Nr = InStr(.Name, " ")
            If Nr > 0 Then
                Fmt = String$(Nr - Pos, "#")
                If Left(.Name, Nr - 1) Like PREFIX & Fmt Then
                    Rp = Mid$(.Name, Nr, Len(.Name) - Nr + 1)
                    .Name = PREFIX & Pnr & Rp
                End If
            End If
        End With
    Next oWs
End Sub

 

[Wizerd]

Works Great...thank you very much

 

[Wizerd]

If the starting book has the Setup sheet, and 3 main sheets, can the 3 main sheets be copied for the amount specified in the setup sheet at B5 first, renaming the TLx at the end of the sheet to the loop number, then run the rename you created above?

 

[GWteB]

You are welcome!

can the 3 main sheets be copied for the amount specified in the setup sheet at B5 first, renaming the TLx at the end of the sheet to the loop number, then run the rename you created above?

Yes, but we can do it also the other way around. This means actually that your ultimate goal determines the best approach. If I had known this beforehand, the code would have looked very different. So please elaborate on what you're finally trying to achieve regarding copying and renaming worksheets, so we can get it right in one time.

 

[Wizerd]

You are welcome!


Yes, but we can do it also the other way around. This means actually that your ultimate goal determines the best approach. If I had known this beforehand, the code would have looked very different. So please elaborate on what you're finally trying to achieve regarding copying and renaming worksheets, so we can get it right in one time.

I appreciate the feedback. The first code is perfect for all the existing workbooks we have. I was merely take a new approach with my second request. Was looking more for future creations of sheets. I appreciate all the help.

 

[GWteB]

This might help you in future ...

Sub Wizerd_r2()

    Const PREFIX As String = "Grp"
    Const SUFFIX As String = "-TL"

    Dim oWs     As Worksheet
    Dim arrOrg  As Variant
    Dim arrNew  As Variant
    Dim Fmt     As String
    Dim Rp      As String
    Dim Lp      As Long
    Dim Nr      As Long
    Dim Pos     As Long
    Dim Pnr     As Variant
    Dim i       As Long
    Dim k       As Long

    Lp = ThisWorkbook.Sheets("Setup").Range("B5").Value

    ' determine worksheets to be copied
    For Each oWs In ThisWorkbook.Worksheets
        If Not StrComp(oWs.Name, "setup", vbTextCompare) = 0 Then
            If InStr(oWs.Name, SUFFIX) > 0 Then
                arrOrg = arrOrg & oWs.Name & "*"
            End If
        End If
    Next oWs
    arrOrg = VBA.Split(arrOrg, "*")
    ReDim Preserve arrOrg(UBound(arrOrg) - 1)

    ' copy worksheet names without trailing number
    arrNew = arrOrg
    For k = LBound(arrOrg) To UBound(arrOrg)
        Nr = InStr(arrOrg(k), SUFFIX)
        arrNew(k) = Left(arrOrg(k), Nr + Len(SUFFIX) - 1)
    Next k

    ' copy worksheets and rename each using new trailing number
    For i = 2 To Lp
        For k = LBound(arrOrg) To UBound(arrOrg)
            With ThisWorkbook
                .Sheets(arrOrg(k)).Copy After:=.Sheets(.Sheets.Count)
                ActiveSheet.Name = arrNew(k) & CStr(i)
            End With
        Next k
    Next i

    ' rename all sheets according group number
    Pnr = ThisWorkbook.Sheets("Setup").Range("B2").Value
    Pos = Len(PREFIX) + 1

    For Each oWs In ThisWorkbook.Worksheets
        With oWs
            Nr = InStr(.Name, "-")
            If Nr > 0 Then
                Fmt = String$(Nr - Pos, "#")
                If Left(.Name, Nr - 1) Like PREFIX & Fmt Then
                    Rp = Mid$(.Name, Nr, Len(.Name) - Nr + 1)
                    .Name = PREFIX & Pnr & Rp
                End If
            End If
        End With
    Next oWs
End Sub

 

[Wizerd]

Works exactly as intended (both of them). Thanks very much.