运行时错误9-将Seet复制到新的wrokbook时下标超出范围

Question

我有一些简单的代码，如下所示：

Private Sub btn_conact_Click()

Dim projectref As String
Dim savelocation As String
Dim projectSearchRange As Range
Dim LastRow As Integer

'set search value (porject key - unique)    
projectref = cmb_Project.Value

Application.ScreenUpdating = False
'find the project reference in the tracking spreadsheet

Sheets("Project Tracking").Activate
Set projectSearchRange = Range("A:A").Find(projectref, , xlValues, xlWhole)
LastRow = projectSearchRange.Row
'file directory to save the new workbook in
savelocation = Cells(LastRow, 5).Value    

'template for the contact list
Sheets("Contact List").Activate

Cells(7, 3).Value = projectref
'create new workbook
Set newWorkbook = Workbooks.Add
With newWorkbook
    .Title = "Contact List for Project" & projectref
    .SaveAs Filename:=savelocation & "/" & projectref & "Contact_List.xlsx"
End With

'Windows("Project tracker spreadsheet VBA").Activate
Sheets("Contact List").Copy Before:=Workbooks(projectref & "Contact_List.xlsx").Sheets("Sheet1") 'runtime error 9: subscript out of range
Windows(projectref & " Contact_List.xlsx").Activate
Application.ScreenUpdating = True

End Sub

可以看出，我在代码的最后4行遇到运行时错误，这实际上是相当重要的一行...

我的问题是，有人能看到我可能在哪里犯了一个错误，从而导致此错误吗？ 是成功创建新工作簿并将其保存在指定位置的，但是当它尝试将所需工作表从旧工作簿（项目跟踪器电子表格VBA）复制到由此代码创建的新工作簿时，它只是掉下来了。

Answer 1

首先，关于您的错误，您已经在使用Set newWorkbook = Workbooks.Add定义和设置新工作Set newWorkbook = Workbooks.Add ，因此，当您在工作簿之间“联系列表”工作表时为什么不使用它。

要在工作簿之间复制工作表，您需要完全限定Worksheet对象ThisWorkbook.Sheets("Contact List").Copy Before:=NewWorkbook.Sheets("Sheet1")

其次，当您可以直接使用完全合格的Range和Worksheets时，最好避免使用Activate 。

完整的编辑代码 ：

Option Explicit

Private Sub btn_conact_Click()

Dim projectref As String
Dim savelocation As String
Dim projectSearchRange As Range
Dim LastRow As Integer
Dim NewWorkbook As Workbook

'set search value (porject key - unique)
projectref = cmb_Project.Value

Application.ScreenUpdating = False

'find the project reference in the tracking spreadsheet
With Sheets("Project Tracking")
    Set projectSearchRange = .Range("A:A").Find(projectref, , xlValues, xlWhole)
    If Not projectSearchRange Is Nothing Then '<-- verify that find was successful
        LastRow = projectSearchRange.Row
        'file directory to save the new workbook in
        savelocation = .Cells(LastRow, 5).Value
    Else '<-- find was unsuccessful
        MsgBox "Unable to find " & projectref
        Exit Sub
    End If
End With

'template for the contact list
Sheets("Contact List").Cells(7, 3).Value = projectref

'create new workbook
Set NewWorkbook = Workbooks.Add
With NewWorkbook
    .Title = "Contact List for Project" & projectref
    .SaveAs Filename:=savelocation & "/" & projectref & "Contact_List.xlsx"
End With

' ===== Fixed the error on thie line =====
ThisWorkbook.Sheets("Contact List").Copy Before:=NewWorkbook.Sheets("Sheet1")
NewWorkbook.Activate '<-- not sure why you want to Activate, but here you go
Application.ScreenUpdating = True

End Sub

Answer 2

我不知道如何在注释中插入代码，因此可以使用答案空间来指导您。 似乎Windows（“ Project tracker电子表格VBA”）不可用。 可能是窗口文本不正确。 为了确认这一点。 请在代码行下方插入已被注释掉的行。 这可能会给您一些线索。

found = False
  For Each Item In Windows
    Debug.Print Item.Caption
    If Item.Caption = "Project tracker spreadsheet VBA" Then
      found = True
      Exit For
    End If
  Next

  If Not found Then
    MsgBox "Window(Project tracker spreadsheet VBA) -  Not found"
  End If