运行时错误9 – 将下划线复制到新的wrokbook时超出范围
我有一个简单的代码如下所示：
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 可以看出，我得到了第四行代码中的运行时错误，这实际上是一个相当重要的行…
我的问题是，任何人都可以看到我可能犯了一个错误，会导致这个错误？ 已成功创build新的工作簿并将其保存在指定的位置，但是当它试图从旧工作簿（Project跟踪器电子表格VBA）复制所需的工作表到由此代码创build的新工作簿时，就会垮台。
首先，关于您的错误，您已经使用Set newWorkbook = Workbooks.Add定义和设置新的工作Set newWorkbook = Workbooks.Add ，那么为什么不在工作簿之间的“联系人列表”表单中使用它。
要在工作簿之间复制工作表，您需要完全限定Worksheet对象， ThisWorkbook.Sheets("Contact List").Copy Before:=NewWorkbook.Sheets("Sheet1")
其次，最好避免使用Activate ，直接使用完全合格的Range和Worksheets 。
完整编辑的代码 ：
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
我不知道如何在评论中插入代码，所以使用答案空间来指导你。 它显示Windows（“项目跟踪器电子表格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