Excel VBA - 从另一个工作簿中的新名称的列重命名所有工作表

Question

这个问题与renaming multiple worksheets from list using VBA 有点相似，但差别太大，无法从那个问题中得到答案。

我将经常需要重命名各种传入工作簿中的数十个工作表。

我希望通过首先将所有工作表名称复制到 secondWorkbook.sheets(1) colA 中，在 ColB 中手动创建新名称，然后运行第二个宏来更新 originalWorkbook 中的名称来重命名所有工作表。

我被困在第二个宏上，但将在下面提供两个宏。 如果有人有更短/更好的方式来编写这些宏，我会全神贯注。

第一个宏 - 将所有工作表名称复制到一个新的 workbook.sheet(1).colA 中。 这可行，并使用 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

这是我坚持的宏。两个工作簿都在屏幕上打开，我不介意编辑宏来提供工作簿名称。不确定如何引用名称为“Book4 - Microsoft Excel”的未保存工作簿，因此我一直将其保存为 Temp.xlsx 并将其引用为 namesWb。带有要重命名的选项卡的工作簿被引用为 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

我意识到我可以再次遍历 targetWb，并且对于每个选项卡名，在 ColA() 中找到该选项卡名的位置，并使用来自 tabB() 的相同位置名重命名它 - 但我想知道是否有更快/更好的方式来做到这一点。

Answer 1

您可以像这样遍历活动工作簿：

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

编辑：由于您只有两个打开的工作簿，您可以缩短它：

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

我已经重构了您的两个Sub 以显示更强大的方法。

1. 使用显式类型调暗所有变量（您的一些变量默认为 Variant）
2. 在名称列表顶部记录正在处理的工作簿
3. 仍在处理 ActiveWorkbook
4. 将 Temp 工作簿保存到与 ActiveWorkbook 相同的文件夹中
5. Rename... 现在会跳过所有缺失的新名称
6. 检测丢失的 OldNames（查看代码中的注释，在此处放置您想要的任何响应）
7. 检测失败的重命名（例如，新名称中的字符可能无效）

---

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