Vba运行时错误9：在工作簿之间复制工作表时，下标超出范围

Question

我正在尝试将工作表从一个工作簿复制到另一个工作簿。当工作簿和工作表的名称被硬编码时，下面的代码工作得很好。

相反，当我尝试引用要从单元格中的文本复制的工作表名称时，我正在

Run-time error '9': Subscript out of range.

粗体线出现错误。我尝试了带引号和不带引号的文本（单引号和双引号）。

Sub copy_dss_data_1()
Dim wkbSource As Workbook
Dim wkbDest As Workbook
Dim shttocopy As Worksheet
Dim wbname As String

' check if the file is open (source file)
ret = Isworkbookopen(ThisWorkbook.Path & "\" & Range("J2"))
If ret = False Then
' open file
Set wkbSource = Workbooks.Open(ThisWorkbook.Path & "\" & Range("J2"))
Else
 Set wkbSource = Workbooks(Strings.Trim(Range("J2")))
 End If

' check if the file is open

ret = Isworkbookopen(ThisWorkbook.Path & "\Book1.xlsm")
If ret = False Then
' open file
Set wkbDest = Workbooks.Open(ThisWorkbook.Path & "\Book1.xlsm")
Else
 Set wkbDest = Workbooks("Book1.xlsm")
 End If

***Set shttocopy = wkbSource.Sheets(Strings.Trim(Range("J3")))
shttocopy.Copy wkbDest.Sheets(1)***

End Sub

Function Isworkbookopen(filename As String)
Dim ff As Long, ErrNo As Long
Dim wkb As Workbook
Dim nam As String

wbname = filename
On Error Resume Next

ff = FreeFile()
Open filename For Input Lock Read As #ff
Close ff
ErrNo = Err
On Error GoTo 0
Select Case ErrNo
Case 0: Isworkbookopen = False
Case 70: Isworkbookopen = True
Case Else: Error ErrNo
End Select

End Function

Answer 1

试试这个。我已经使用一些额外的函数（GetWorkbook和SheetExists）简化了代码，以消除一些冗余。此外，假设J2 / J3中的值位于ThisWorkbook和活动工作表中，您需要在可能打开其他工作簿之前将这些值捕获到变量，然后，使用变量传递值：

Sub copy_dss_data_1()
    Dim wkbSource As Workbook
    Dim wkbDest As Workbook
    Dim shttocopy As Worksheet
    Dim wbname As String
    Dim shCopy$

    ' get sheet name & filename BEFORE opening any new file(s)
    wbName = Range("J2")
    shCopy = Range("J3")

    Set wkbSource = GetWorkbook(ThisWorkbook.Path, wbName)
    Set wkbDest = GetWorkbook(ThisWorkbook.Path, "Book1.xlsm")

    If SheetExists(wkbSource, shCopy) Then
        Set shttocopy = wkbSource.Sheets(Strings.Trim(shCopy))
        shttocopy.Copy wkbDest.Sheets(1)
    Else
        MsgBox shCopy & " doesn't exist in " & wkbSource.Name
    End If
End Sub
Function GetWorkbook(path$, name$)
' Returns the specified workbook&path
    If Isworkbookopen(path & "\" & name) Then
    ' open file
        Set GetWorkbook = Workbooks.Open(path & "\" & name)
    Else
        Set GetWorkbook = Workbooks(Strings.Trim(name))
    End If
End Function
Function SheetExists(wb as Workbook, s$)
' checks if sheet exists in the wb
        ret = ""
        On Error Resume Next
        ret = wb.Sheets(s).Name
        SheetExists = ret <> ""
End Function
Function Isworkbookopen(filename As String)
    Dim ff As Long, ErrNo As Long
    Dim wkb As Workbook
    Dim nam As String

    wbname = filename
    On Error Resume Next

    ff = FreeFile()
    Open filename For Input Lock Read As #ff
    Close ff
    ErrNo = Err
    On Error GoTo 0
    Select Case ErrNo
        Case 0: Isworkbookopen = False
        Case 70: Isworkbookopen = True
        Case Else: Error ErrNo
    End Select

End Function