複数のExcelファイルを複数の行から生成する

Question

Excelのリストから複数のExcelファイルを生成しようとしています。以下のコードは、私が試みたが、実行時エラーを得ている70

私はExcelを使用している（ここでダウンロードすることができた。https://drive.google.com/folderview?id=0B7u1K6cUEOzeWURZWWd3NjQ4R0k&usp=sharing）

1）BasicInvoice.xlsx 2）2011.xlsx

Private Sub CommandButton1_Click() 

Dim Name As String 
Dim invoicenumber As Long 
Dim r As Long 
Dim path As String 
Dim myfilename As String 
lastrow = Sheets("1").Range("A" & Rows.Count).End(xlUp).Row 
r = 2 
For r = 2 To lastrow 

Date = Sheets("1").Cells(r, 1).Value 
invoicenumber = Sheets("1").Cells(r, 2).Value 
Name = Sheets("1").Cells(r, 3).Value 
Description = Sheets("1").Cells(r, 4).Value 
Amount = Sheets("1").Cells(r, 5).Value 

Workbooks.Open ("BasicInvoice.xlsx") 
ActiveWorkbook.Sheets("BasicInvoice").Activate 
ActiveWorkbook.Sheets("BasicInvoice").Range("E9").Value = Date 
ActiveWorkbook.Sheets("BasicInvoice").Range("E10").Value = invoicenumber 
ActiveWorkbook.Sheets("BasicInvoice").Range("B9").Value = Name 
ActiveWorkbook.Sheets("BasicInvoice").Range("B16").Value = Description 
ActiveWorkbook.Sheets("BasicInvoice").Range("E16").Value = Amount 

path = "C:\invoices\" 
ActiveWorkbook.SaveCopyAs Filename:=path & invoicenumber & ".xlsx" 
myfilename = ActiveWorkbook.FullName 
Application.DisplayAlerts = True 
ActiveWorkbook.PrintOut copies:=1 
ActiveWorkbook.Close SaveChanges:=False 

nextrow: 

Next r 

End Sub 

Answer 1

ランタイムエラー70は、書き込み保護されているものに書き込めないことを示します。どのラインでエラーが発生していますか？

実際には、C：/ Invoicesフォルダがハードドライブに存在することを確認してください。

私がここにいる間、以下はあなたのコードの整頓です。

Private Sub CommandButton1_Click() 

Dim wbInv As Workbook, wsInv As Worksheet 
Dim wbSrc As Workbook, wsSrc As Worksheet 
Dim lastrow As Long, r As Long 
Dim path As String 

Set wbSrc = ThisWorkbook 
Set wsSrc = wbSrc.Sheets("1") 
Set wbInv = Workbooks.Open("BasicInvoice.xlsx") 
Set wsInv = wbInv.Sheets("BasicInvoice") 
path = "C:\invoices\" 
lastrow = wsSrc.Range("A" & Rows.Count).End(xlUp).Row 

Application.ScreenUpdating = False 

    For r = 2 To lastrow 

     With wsInv 
      .Range("E9").Value = wsSrc.Cells(r, 1).Value 
      .Range("E10").Value = wsSrc.Cells(r, 2).Value 
      .Range("B9").Value = wsSrc.Cells(r, 3).Value 
      .Range("B16").Value = wsSrc.Cells(r, 4).Value 
      .Range("E16").Value = wsSrc.Cells(r, 6).Value 
     End With 

     With wbInv 
      .SaveCopyAs Filename:=path & wsInv.Range("E10").Value & ".xlsx" 
      .PrintOut copies:=1 
     End With 

    Next r 

wbInv.Close SaveChanges = False 


Application.ScreenUpdating = True 

End Sub