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

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

对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)是指您的源工作簿对象，因此您必须指定要计数另一本书中的工作表。

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

2 个答案: