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定义并设置了新工作簿，那么为什么不在工作簿之间的“联系人列表”表单中使用它。

要在工作簿之间复制工作表，您需要完全限定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

Answer 2

我不知道如何在评论中插入代码，因此使用答案空间来指导您。似乎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

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

2 个答案: