ランタイムエラー9 - 範囲外の添字新しいwrokbook

Question

にseetをコピーするときに、以下のように私は、コードの単純なビットを持っています見ることができます

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で新しいブックを設定し、なぜときワークブック間のあなたは「連絡先リスト」シートを使用していません。

はワークブック間のワークシートをコピーするには、あなたが完全修飾 Range sおよび Worksheetsを直接操作することができるとき、それは Activateの使用を避けた方が良いですが、完全に、 ThisWorkbook.Sheets("Contact List").Copy Before:=NewWorkbook.Sheets("Sheet1")

セカンドをWorksheetオブジェクトを修飾する必要があります。

全編集コード：。

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