VBA：如果工作簿中的工作表名称等于从用户窗体中选择的组合框值，则复制该工作表并将其粘贴到另一个工作簿中

Posted 2023-02-24

【中文标题】VBA：如果工作簿中的工作表名称等于从用户窗体中选择的组合框值，则复制该工作表并将其粘贴到另一个工作簿中

【英文标题】：VBA: If Worksheet name in Workbook equals Combo Box value selected from Userform then copy that Worksheet and paste it into another Workbook

【发布时间】：2019-01-22 18:37:01

【问题描述】：

我正在开发一个用户窗体，它将从工作簿 A 复制特定工作表并将其粘贴到工作簿 B 中（本质上是归档该数据）。 Userform 向用户显示一个组合框下拉列表，以选择要复制的工作表名称。但是，在使用 sheet.copy 命令时，我收到了一个下标超出范围的错误。这是我的代码，为了便于阅读而修改了名称：

    Dim ws as Worksheet
    Dim WorkbookA as Workbook
    Dim WorkbookB as Workbook
    Dim ComboBoxValue as String


    Set WorkbookA as ActiveWorkbook
    Set WorkbookB as Workbook.Open("C:File Path Here")

    With ThisWorkbook
        For Each ws In Application.ActiveWorkbook.Worksheets
            If ws.Name = UserForm1.ComboBox1.Text Then
                ComboBoxValue = ws.Name
                Worksheets(ComboBoxValue).Copy _ 
                After:=Workbooks("Workbook B.xlsm").Sheets(Sheets.Count) 
                ' Run-Time 9 Subscript Out of Range Error occurs on line above ^
                ActiveSheet.Name = UserForm1.ComboBoxSelection.Text
                WorkbookB.Save
                WorkbookB.Close
                WorkbookA.Activate
                Application.CutCopyMode = False
            End If
        Next ws
    End With

【参考方案1】：

您的错误的根源是对工作簿的不正确引用。还有很多其他问题。

对ThisWorkbook 的不必要引用 不必要的循环遍历所有工作表 复制工作表的不必要重命名 对ActiveWorkbook 和ActiveSheet 的引用不正确/不正确 无错误处理 缩进不当

您的代码，已重构。这被写为用户窗体中的按钮单击事件。更新以满足您的需求。

Option Explicit

Const ArchiveFilePath As String = "C:\Path\To\ArchiveBook.xlsx"

Private Sub CommandButton1_Click()
    Dim ws As Worksheet
    Dim WorkbookA As Workbook
    Dim WorkbookB As Workbook
    Dim wsName As String

    Application.ScreenUpdating = False

    Set WorkbookA = ActiveWorkbook

    wsName = UserForm1.ComboBox1.Text
    If wsName = vbNullString Then Exit Sub

    On Error Resume Next 'Handle possibility that Open fails
    Set WorkbookB = Workbooks.Open(ArchiveFilePath)
    On Error GoTo 0
    If WorkbookB Is Nothing Then
        MsgBox "Failed to open " & ArchiveFilePath, vbOKOnly, "Error"
        Exit Sub
    End If

    'Check if specified ws already exists in WorkbookB
    Set ws = GetWorksheet(WorkbookB, wsName)
    If Not ws Is Nothing Then
        ' Sheet already exists.  What now?
        MsgBox "Sheet " & wsName & " already exists in " & WorkbookB.Name & ".  What now?", vbOKOnly, "Error"
        WorkbookB.Close
        Exit Sub
    End If

    Set ws = GetWorksheet(WorkbookA, wsName)
    If ws Is Nothing Then
        MsgBox "Sheet " & wsName & " does not exist in " & WorkbookA.Name, vbOKOnly, "Error"
        WorkbookB.Close
        Exit Sub
    End If

    ws.Copy After:=WorkbookB.Sheets(WorkbookB.Sheets.Count)

    WorkbookB.Save
    WorkbookB.Close

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Private Function GetWorksheet(wb As Workbook, wsName As String) As Worksheet
    On Error GoTo EH
    Set GetWorksheet = wb.Worksheets(wsName)
EH:
End Function

【讨论】：

感谢您的宝贵时间和帮助。我很欣赏您的深入回应，仅仅通过阅读您的改进，我就学到了很多东西。这是我 VBA 编程的第 1 个月，我还有很多东西要学。

【参考方案2】：

将Sheets(Sheets.Count) 更改为Sheets(Workbooks("Workbook B.xlsm").Sheets.Count)

在这种情况下，Sheets(Sheets.Count) 指的是您的源工作簿对象，因此您必须指定计算另一本书中的工作表。

【讨论】：

Unqualified Sheets 暗指ActiveWorkbook。 Sheets(Workbooks(...)) 没有解决这个问题。

这是我正在寻找答案的根本错误。感谢您的时间和帮助。然而，我必须给 Chris Neilsen 最好的答案，因为他解决了我什至没有考虑过的其他潜在问题。

当然，它是 - 但是当他执行复制方法时，它正在从活动工作簿复制工作表。在该方法完成之前，BookB 不会成为活动工作簿。这将解决他描述的下标超出范围错误。

@MathieuGuindon 这也是我最初的想法，然后意识到他只引用了相关代码行的 part。所以建议实际上是After:=Workbooks("Workbook B.xlsm").Sheets(Workbooks("Workbook B.xlsm").Sheets.Count)。笨拙，但适用于那条线

@ChrisMeurer 但是当他执行复制方法时，它是从活动工作簿中复制工作表。 实际上不，不是。它使用 ws.Copy ，不依赖 Active 任何东西