Excel VBA - rename all worksheets from col of new names in another workbook

Question

This question is vaguely similar to renaming multiple worksheets from list using VBA , but is too different to get the answer from that question.

I will regularly need to rename dozens of worksheets in various incoming workbooks.

I wish to rename all worksheets by first copying all the worksheet names into a secondWorkbook.sheets(1) colA, manually creating new names in ColB, and then run a second macro to update the names in the originalWorkbook.

I am stuck on the second macro, but will provide both macros below. If anyone has a shorter/better way of writing these macros, I am all eyes.

First macro - copy all worksheet names into a new workbook.sheet(1).colA. This works, and creates a new unsaved workbook with the tab names in ColA

Sub GrabAllTabNamesIntoTempWorkbookColA()
    Dim tst, tmp, allTabNames As String
    Dim i, cnt, cnt2 As Long
    Dim wb, wbTmp As Workbook, xWs, ws1 As Worksheet
    Dim arrOldNames, arrNewNames As Variant

    ReDim arrOldNames(999)
    cnt = 0

    With ActiveWorkbook
        For Each xWs In .Worksheets
            If xWs.Visible = xlSheetVisible Then
                arrOldNames(cnt) = xWs.Name
                cnt = cnt + 1
            End If
        Next
    End With
    ReDim Preserve arrOldNames(cnt - 1)

    cnt2 = 1
    Set wbTmp = Workbooks.Add
    Set ws1 = wbTmp.Sheets(1)
    For i = 1 To cnt
        ws1.Range("A" & i).Value = arrOldNames(i - 1)
    Next

    MsgBox "Done. Copied " & cnt & " tab names."

End Sub

Here is the macro I am stuck on. Both workbooks are open on screen, and I don't mind editing the macro to provide the workbook names. Unsure how to reference an unsaved workbook with a name like "Book4 - Microsoft Excel", so I have been saving it as Temp.xlsx and referencing it as namesWb . The workbook with the tabs to be renamed is referenced as targetWb

Sub RenameAllTabsFromColAInTempWorkbook()
    Dim namesWb, targetWb As Workbook
    Dim colA, colB As Variant

    Set namesWb = Windows("Temp.xlsx")
    Set targetWb = ActiveWorkbook

    ReDim colA(999), colB(999)
    cnt = 0
    With namesWb
        Sheets(1).Activate
        For i = 1 To 999
            If Range("A" & i).Value = "" Then Exit For
            colA(i - 1) = Range("A" & i).Value
            colB(i - 1) = Range("B" & i).Value
            cnt = cnt + 1
        Next
        ReDim Preserve colA(cnt)
        ReDim Preserve colB(cnt)
    End With

    For each oldname in colA()
        'Stuck here... 
    Next
End Sub

I realize that I could again loop through the targetWb and, for each tabname, find the location of that tabname in ColA() and rename it with the same position name from tabB() - but I am wondering if there is a faster/better way to do this.

Answer 1

You can loop through active workbooks like this:

Sub t()
Dim mainWB As Workbook, tempWB As Workbook
Dim wb As Workbook

Set mainWB = ActiveWorkbook

For Each wb In Application.Workbooks
    'Loops through the workbooks.
    Debug.Print wb.Name
    If wb.Name Like "Book*" Then
        Set tempWB = wb
    End If
Next wb

End Sub

Edit: Since you only have two open workbooks, you can shorten that:

Sub t()
Dim mainWB As Workbook, tempWB As Workbook
Dim wb As Workbook

Set mainWB = ActiveWorkbook ' MAKE SURE THIS IS CORRECT!! May need `ThisWorkbook` if the new temporary one becomes the active one.

For Each wb In Application.Workbooks
    'Loops through the workbooks.
    Debug.Print wb.Name
    If wb.Name <> mainWB.Name And wb.Name <> "PERSONAL.XLSB" Then
        Set tempWB = wb
        ' Now do whatever you need with the Temporary workbook.
    End If
Next wb

End Sub

Answer 2

I've refactored both your Sub 's to show a more robust method.

1. Dim all variables, with explicit types (some of yours were defaulting to Variant)
2. Record the Workbook being processed in the top of the Names list
3. Still processes the ActiveWorkbook
4. Save the Temp workbook into the same folder as ActiveWorkbook
5. Rename... now skips any missing new names
6. Detect missing OldNames (see comment in code, place any response you want there)
7. Detect failed Renames (eg could be invalid characters in the new names)

---

Sub GrabAllTabNamesIntoTempWorkbookColA()
    Dim wbToRename As Workbook
    Dim wbTmp As Workbook
    Dim xWs As Worksheet
    Dim ws1 As Worksheet
    Dim arrOldNames As Variant
    Dim arrNewNames As Variant
    Dim cnt As Long

    Set wbToRename = ActiveWorkbook
    With wbToRename
        ' Size array based on number of sheets in workbook
        ReDim arrOldNames(1 To .Worksheets.Count, 1 To 1)
        cnt = 0
        For Each xWs In .Worksheets
            If xWs.Visible = xlSheetVisible Then
                cnt = cnt + 1
                arrOldNames(cnt, 1) = xWs.Name
            End If
        Next
    End With


    Set wbTmp = Workbooks.Add
    Set ws1 = wbTmp.Sheets(1)
    'Place data in sheet in one go
    ws1.Cells(1, 1) = wbToRename.Name
    ws1.Cells(2, 1).Resize(UBound(arrOldNames, 1), 1) = arrOldNames

    MsgBox "Done. Copied " & cnt & " tab names."

    'Save workbook
    wbTmp.SaveAs Filename:=wbToRename.Path & "\Temp", FileFormat:=xlOpenXMLWorkbook
End Sub

Sub RenameAllTabsFromColAInTempWorkbook()
    Dim namesWb As Workbook
    Dim targetWb As Workbook
    Dim wsNames As Worksheet
    Dim ws As Worksheet
    Dim NamesList As Variant
    Dim cnt As Long
    Dim i As Long

    Set namesWb = Application.Workbooks("Temp.xlsx")
    Set targetWb = Application.Workbooks(namesWb.Worksheets(1).Cells(1, 1).Value)

    cnt = 0
    Set wsNames = namesWb.Worksheets(1)
    With wsNames
        'Get Names into one variable, based on actual number of rows
        NamesList = wsNames.Range(wsNames.Cells(2, 2), wsNames.Cells(wsNames.Rows.Count, 1).End(xlUp)).Value
        For i = 1 To UBound(NamesList, 1)
            ' Check if the Name has been entered
            If NamesList(i, 2) <> vbNullString Then
                'Get reference to sheet by old name, and handle if sheet is missing
                Set ws = Nothing
                On Error Resume Next
                Set ws = targetWb.Worksheets(NamesList(i, 1))
                On Error GoTo 0
                ' Rename sheet
                If Not ws Is Nothing Then
                    On Error Resume Next
                    ws.Name = NamesList(i, 2)
                    On Error GoTo 0
                    If ws.Name <> NamesList(i, 2) Then
                        ' Rename failed! What now?
                    End If
                Else
                    'Sheet Missing! What now?
                End If
            End If
        Next
    End With

End Sub