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

Question

我正在处理一个用户窗体，该窗体将从工作簿A复制特定的工作表并将其粘贴到工作簿B中（实质上是将数据存档）。 用户表单向用户显示一个组合框下拉列表，以选择要复制的工作表名称。 但是，当我使用sheets.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

Answer 1

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

• Unnecassary参考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

Answer 2

变更Sheets(Sheets.Count)以Sheets(Workbooks("Workbook B.xlsm").Sheets.Count)

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