写一个 Header 到多个 Workbos

Question

我正在根据项目计数动态创建一个 Excel 工作簿 - 我想在每个工作簿中编写本质上相同的 header。我的以下语法适用于第一个工作簿，但第二个创建新工作簿时抛出错误

这是我的语法 - 我需要做什么才能将 header 行写入创建的每个工作簿？

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") = name
  Set xlR = xlWb.Worksheets(1).Range("$N")
  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") = name
           Set xlR = xlWb.Worksheets(1).Range("$Q")
        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") = name
               Set xlR = HeaderWrite.Range("$N")
           Else
               HeaderWrite.Range("$C") = name
               Set xlR = HeaderWrite.Range("$Q")
           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

写一个 Header 到多个 Workbos

Write A Header To Multiple WOrkbos

ms-access

vba

ms-access-2013