将工作表从另一个工作簿 (#2) 导入到当前工作簿 (#1)

Question

我编写了一个代码，它打开了一个窗口，我可以在该窗口中选择一个我想要复制和导入工作表的 Excel 工作簿 (#2)。 然后，代码会检查打开的工作簿（#2）中是否存在所需的工作表（名为“Guidance”）。如果存在，则应将其复制并粘贴到当前工作簿（#1）中。 粘贴工作表后，工作簿 (#2) 应再次关闭。

到目前为止，代码完成了我想要它做的事情，因为它打开了窗口并让我选择想要的工作表（名为“Guidance”），但我有错误（不确定翻译是否正确）

“运行时错误'9'：索引超出范围”

应该复制和粘贴工作表的位置。

对此的任何帮助将不胜感激！提前致谢。

 Private Function SheetExists(sWSName As String, Optional InWorkbook As Workbook) As Boolean

 If InWorkbook Is Nothing Then
    Set InWorkbook = ThisWorkbook
 End If

 Dim ws As Worksheet
 On Error Resume Next
 Set ws = Worksheets(sWSName)
 If Not ws Is Nothing Then SheetExists = True

 On Error GoTo 0

 End Function


 Sub GuidanceImportieren()


 Dim sImportFile As String, sFile As String
 Dim sThisWB As Workbook
 Dim vFilename As Variant

 Application.ScreenUpdating = False
 Application.DisplayAlerts = False

 Set sThisWB = ActiveWorkbook
 sImportFile = Application.GetOpenFilename("Microsoft Excel Workbooks, 
 *xls; *xlsx; *xlsm")

 If sImportFile = "False" Then
 MsgBox ("No File Selected")
 Exit Sub

 Else
 vFilename = Split(sImportFile, "|")
 sFile = vFilename(UBound(vFilename))
 Application.Workbooks.Open (sImportFile)

 Set wbWB = Workbooks("sImportFile")
 With wbWB
 If SheetExists("Guidance") Then
 Set wsSht = .Sheets("Guidance")
 wsSht.Copy Before:=sThisWB.Sheets("Guidance")
 Else
 MsgBox ("No worksheet named Guidance")
 End If

 wbWB.Close SaveChanges:=False
 End With
 End If

 Application.ScreenUpdating = True
 Application.DisplayAlerts = True

 End Sub

Answer 1

问题来了

Set wbWB = Worksheets("Guidance") '<-- this should be a workbook not a worksheet?
With wbWB '<-- this with is useless until …
    If SheetExists("Guidance") Then
        Set wsSht = .Sheets("Guidance") '<-- … until Sheets here starts with a dot
        wsSht.Copy Before:=sThisWB.Sheets("Guidance") 'if the error is here then there is no sheet "Guidance" in sThisWB
    Else
        MsgBox ("No worksheet named Guidance")
    End If
    wbWB.Close SaveChanges:=False
End With

另请注意，SheetExists("Guidance") 不会签入特定工作簿（可能会失败）。我建议将功能扩展到：

Private Function SheetExists(WorksheetName As String, Optional InWorkbook As Workbook) As Boolean
    If InWorkbook Is Nothing Then
        Set InWorkbook = ThisWorkbook 'fallback if not set
    End If

    Dim ws As Worksheet
    On Error Resume Next
    Set ws = InWorkbook.Worksheets(WorksheetName)
    SheetExists = Not ws Is Nothing
    On Error Goto 0 'necessary because the Err.Number will not be cleared on End Function
End Function

因此您可以测试工作表是否存在于特定工作簿中，例如

SheetExists("Guidance", sThisWB)
SheetExists("Guidance", wbWB)

---

Sub GuidanceImportieren()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim sImportFile As String
    sImportFile = Application.GetOpenFilename("Microsoft Excel Workbooks, *xls; *xlsx; *xlsm")

    If sImportFile = False Then 'false should not be "false"
        MsgBox "No File Selected"
        Exit Sub
    Else
        Dim vFilename As Variant
        vFilename = Split(sImportFile, "|")

        Dim sFile As String
        sFile = vFilename(UBound(vFilename))

        Dim ImportWorkbook As Workbook
        Set ImportWorkbook = Application.Workbooks.Open(sImportFile)

        If SheetExists("Guidance", ImportWorkbook) Then
            ImportWorkbook.Sheets("Guidance").Copy Before:=ThisWorkbook.Sheets("Guidance")
            'you might need to change it into something like this:
        Else
            MsgBox "No worksheet named Guidance"
        End If

        ImportWorkbook.Close SaveChanges:=False
    End If

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub