Question

我基于项目计数动态创建Excel工作簿 - 我想要为每个工作簿编写相同的标题。我的下面的语法适用于第一个工作簿，但第二个是创建一个新的工作簿，引发错误

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

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

为多个WOrkbos写一个标题

1 个答案: