複数のWOrkbosにヘッダーを書き込む

Question

私は、アイテム数に基づいてExcelワークブックを動的に作成しています。そして、各ワークブックに本質的に同じヘッダーを書きたいと思います。私の下の構文は、最初のブックには機能しますが、2番目に新しいブックが作成され、エラーがスローされます。

これは私の構文です - ヘッダー行が作成された各ブックに書き込まれるようにするにはどうすればよいですか？

Set xlApp = CreateObject("Excel.Application") 
xlApp.Visible = True 
Do While Not rs1.EOF 
    i = 0 
    x = 1 
    name = rs1.Fields(0).Value 
    Set xlWb = xlApp.Workbooks.Add 
    row = 1 
    xyz = 0  
    Set HeaderWrite = xlWb.Worksheets(1)  
    HeaderWrite.Cells(row, xyz + 1).Value = "Header 1" 
    xyz = xyz + 1 
    HeaderWrite.Cells(row, xyz + 1).Value = "Header 2" 
    xyz = xyz + 1 
    HeaderWrite.Cells(row, xyz + 1).Value = "Header 3" 
    xyz = xyz + 1 
    HeaderWrite.Cells(row, xyz + 1).Value = "Header 4" 
    xyz = xyz + 1 
    HeaderWrite.Cells(row, xyz + 1).Value = "Header 5" 
    xyz = xyz + 1 
    HeaderWrite.Cells(row, xyz + 1).Value = "Header 6" 
    xyz = xyz + 1 
    HeaderWrite.Cells(row, xyz + 1).Value = "Header 7" 
    xyz = xyz + 1 
    HeaderWrite.Cells(row, xyz + 1).Value = "Header 8" 
    xyz = xyz + 1 
    HeaderWrite.Cells(row, xyz + 1).Value = "Header 9" 
    xyz = xyz + 1  
    xlWb.Worksheets(1).Range("$A$2") = name 
    Set xlR = xlWb.Worksheets(1).Range("$N$2") 
    Set rs2 = Db.OpenRecordset("SELECT * FROM MasterDB", dbOpenDynaset) 
    With rs2 
    .MoveLast 
    .MoveFirst 
    Do While Not .EOF 
     xlR.Value = .Fields(0).Value 
     xlR.Offset(ColumnOffset:=1).Value = .Fields(2).Value 
     xlR.Offset(ColumnOffset:=2).Value = "Mainstreem" 
     HeaderWrite.Cells(row, xyz + 1).Value = "Dept_" & i 
     xyz = xyz + 1 
     HeaderWrite.Cells(row, xyz + 1).Value = "Item" & i 
     xyz = xyz + 1 
     HeaderWrite.Cells(row, xyz + 1).Value = "CRN" & i 
     xyz = xyz + 1 
     i = i + 1 
     Debug.Print i 
     If i = 50 Then 
      i = 0 
      x = x + 1 
      xlWb.SaveAs FileName:=sPath & sFile, FileFormat:=xlOpenXMLWorkbook 
      xlWb.Close SaveChanges:=True 
      Set xlWb = xlApp.Workbooks.Add 
      sFile = name & "_" & "SalesLog" & x & ".xlsx" 
      xlWb.Worksheets(1).Range("$C$2") = name 
      Set xlR = xlWb.Worksheets(1).Range("$Q$2") 
     Else 
      Set xlR = xlR.Offset(ColumnOffset:=3) 
     End If 
     .MoveNext 
    Loop 
    .Close 
    End With 

Answer 1

これは完全にテストされていないですが、うまくいけば、私は正しいスポットに物事を移動した：

Set xlApp = CreateObject("Excel.Application") 
xlApp.Visible = True 
Do While Not rs1.EOF 
    i = 0 
    x = 0 ' was 1 ?? 
    name = rs1.Fields(0).Value 
    Set rs2 = Db.OpenRecordset("SELECT * FROM MasterDB", dbOpenDynaset) 
    With rs2 
    .MoveLast 
    .MoveFirst 
    Do While Not .EOF 
     If i = 0 Then 
      Set xlWb = xlApp.Workbooks.Add 
      row = 1 ' This always stays as 1 ?!?! 
      xyz = 0  
      Set HeaderWrite = xlWb.Worksheets(1)  
      xyz = xyz + 1 : HeaderWrite.Cells(row, xyz).Value = "Header 1" 
      xyz = xyz + 1 : HeaderWrite.Cells(row, xyz).Value = "Header 2" 
      xyz = xyz + 1 : HeaderWrite.Cells(row, xyz).Value = "Header 3" 
      xyz = xyz + 1 : HeaderWrite.Cells(row, xyz).Value = "Header 4" 
      xyz = xyz + 1 : HeaderWrite.Cells(row, xyz).Value = "Header 5" 
      xyz = xyz + 1 : HeaderWrite.Cells(row, xyz).Value = "Header 6" 
      xyz = xyz + 1 : HeaderWrite.Cells(row, xyz).Value = "Header 7" 
      xyz = xyz + 1 : HeaderWrite.Cells(row, xyz).Value = "Header 8" 
      xyz = xyz + 1 : HeaderWrite.Cells(row, xyz).Value = "Header 9" 
      If x = 0 Then 
       HeaderWrite.Range("$A$2") = name 
       Set xlR = HeaderWrite.Range("$N$2") 
      Else 
       HeaderWrite.Range("$C$2") = name 
       Set xlR = HeaderWrite.Range("$Q$2") 
      End If 
     End If 
     xlR.Value = .Fields(0).Value 
     xlR.Offset(ColumnOffset:=1).Value = .Fields(2).Value 
     xlR.Offset(ColumnOffset:=2).Value = "Mainstreem" 
     xyz = xyz + 1 : HeaderWrite.Cells(row, xyz).Value = "Dept_" & i 
     xyz = xyz + 1 : HeaderWrite.Cells(row, xyz).Value = "Item" & i 
     xyz = xyz + 1 : HeaderWrite.Cells(row, xyz).Value = "CRN" & i 
     Set xlR = xlR.Offset(ColumnOffset:=3) 
     i = i + 1 
     Debug.Print i 
     If i = 50 Then 
      i = 0 
      x = x + 1 
      'I moved this up - otherwise I don't think you have a filename 
      sFile = name & "_" & "SalesLog" & x & ".xlsx" 
      xlWb.SaveAs FileName:=sPath & sFile, FileFormat:=xlOpenXMLWorkbook 
      xlWb.Close SaveChanges:=True 
     End If 
     .MoveNext 
    Loop 
    .Close 
    End With