怪!VB导出数据EXCEL连续操作竟不能设置格式

Question

用VB导出数据到EXCEL,窗口第一次运行导出的数据格式(自定义字体,合并单元格)正常,第二次\第三次运行窗口进行导出时,竟不能按照自定义格式进行导出,请大哥们帮忙看看.代码如下:private sub command3_click()
                Dim xlApp As Excel.Application
                Dim xlBook As Excel.Workbook
                Dim xlSheet As Excel.Worksheet
                Set xlApp = CreateObject("Excel.Application")                On Error Resume Next
                Set xlBook = xlApp.Workbooks.add
                Set xlSheet = xlBook.Worksheets(1)
                xlApp.Visible = False
                xlSheet.Activate
                If Combo3.Text = "第一季度" And Option2.Value = True Then
                
                        '处理数据,填充Excel表
                        xlSheet.Range(Cells(1, 1), Cells(1, 9)).Merge  '合并单元格
                        xlSheet.Cells(1, 1) = "资金发放明细表"
                        xlSheet.Range(Cells(1, 1), Cells(1, 9)).Characters.Font.Name = "黑体"   '设置标题为黑体,18号
                        xlSheet.Range(Cells(1, 1), Cells(1, 9)).Characters.Font.Size = 18
                    
                        xlSheet.Rows.RowHeight = 21
                        xlSheet.Range(Cells(2, 1), Cells(2, 256)).Characters.Font.Name = "宋体"  '设置表头为宋体,10号,加粗
                        xlSheet.Range(Cells(2, 1), Cells(2, 256)).Characters.Font.Size = 10
                        xlSheet.Range(Cells(2, 1), Cells(2, 256)).Characters.Font.FontStyle = "加粗"
                        
                        xlSheet.Range(Cells(3, 1), Cells(65536, 256)).Characters.Font.Name = "宋体"  '设置内容为宋体,10号
                        xlSheet.Range(Cells(3, 1), Cells(65536, 256)).Characters.Font.Size = 10
                        
                        xlSheet.Range(Cells(1, 1), Cells(65536, 256)).HorizontalAlignment = 3        '设置内容为水平对齐
                        xlSheet.Range(Cells(1, 1), Cells(65536, 256)).VerticalAlignment = 2          '设置内容为垂直对齐
                        
                        xlSheet.Cells(2, 1) = "乡名"
                        xlSheet.Cells(2, 2) = "村名"
                        xlSheet.Cells(2, 3) = "组名"
                        
                        xlSheet.Cells(2, 4) = "编号"
                        xlSheet.Cells(2, 5) = "户主"
                        xlSheet.Cells(2, 6) = "受益人"
                        
                        xlSheet.Cells(2, 7) = "金额"
                        xlSheet.Cells(2, 8) = "资金说明"
                        xlSheet.Cells(2, 9) = "备注"
                        
                        i = 3
                        While Not rs.EOF
                            xlSheet.Cells(i, 1) = rs.Fields("xming")
                            xlSheet.Cells(i, 2) = rs.Fields("cming")
                            xlSheet.Cells(i, 3) = rs.Fields("zming")
                            
                            xlSheet.Cells(i, 4) = rs.Fields("twbhao")
                            xlSheet.Cells(i, 5) = rs.Fields("twhzhu")
                            xlSheet.Cells(i, 6) = rs.Fields("twsyren")
                            
                            xlSheet.Cells(i, 7) = rs.Fields("je")
                            xlSheet.Cells(i, 8) = rs.Fields("zjsming")
                            xlSheet.Cells(i, 9) = rs.Fields("bzhu")
                            rs.MoveNext
                            i = i + 1
                        Wend                End If
                xlBook.SaveAs Text1.Text     '保存Excel表格
                MsgBox "数据导出成功!", vbInformation, systitle
                
                xlApp.Visible = True '显示表格
                Set xlApp = Nothing '交还控制给Excel
                Set xlBoook = Nothing
                Set xlSheet = Nothingend sub
谢谢!

Answer 1

理论上不会这样的，请确保其它地方都正确。把On Error Resume Next去掉再看。

Answer 2

就是有问题才会这样，你把On Error Resume Next去掉程序就执行不了了，不信试看看。

Answer 3

实在不喜欢 On Error Resume Next

Answer 4

用代码实现EXCEL的设计比较麻烦，你可以自己设计好一个EXCEL表，然后调用这个设计好的表，将记录按设计好的格式导入到EXCEL里。我有一段代码如下，可以参考参考：
Private Sub Command3_Click()
Dim xlApp As excel.Application '定义EXCEL类
Dim xlBook As excel.Workbook '定义工件簿类
Dim xlsheet As excel.Worksheet
Dim sql As String
Dim msgtext As String
Dim objrst As ADODB.Recordset
sql = "select * from fenxianfenxi where time='" & Format$(DTPicker1.Value) & "'  "
Set objrst = ExecuteSQL(sql, msgtext)If Dir(App.Path & "\Temp\excel.bz") = "" Then '判断EXCEL是否打开
    Set xlApp = CreateObject("Excel.Application") '创建EXCEL应用类
    xlApp.Visible = False '设置EXCEL可见
    Set xlBook = xlApp.Workbooks.Open(App.Path & "\temp\fxfx.xls") '打开EXCEL工作簿
    Set xlsheet = xlBook.Worksheets(1) '打开EXCEL工作表
    xlsheet.Activate '激活工作表
    xlsheet.Cells(2, 2) = Format$(DTPicker1.Value, "yyyy年mm月dd日")
    xlsheet.Cells(2, 5) = Trim(Combo1.Text)
     xlsheet.Cells(2, 10) = Trim(Label15.Caption)
     xlsheet.Cells(2, 12) = Trim(Label16.Caption)
     xlsheet.Cells(5, 1) = Trim(RTBox1.Text)
  
     xlsheet.Cells(18, 2) = Trim(RTBox2.Text)
     xlsheet.Cells(19, 2) = Trim(RTBox3.Text)
     xlsheet.Cells(20, 2) = Trim(RTBox4.Text)
     xlsheet.Cells(21, 2) = Trim(RTBox5.Text)
    xlsheet.Cells(23, 1) = Trim(RTBox6.Text)
     xlsheet.Cells(30, 1) = Trim(RTBox7.Text)
      xlsheet.Cells(5, 8) = Trim(RTBox8.Text)
       xlsheet.Cells(23, 8) = Trim(RTBox9.Text)
       xlsheet.Cells(41, 1) = Trim(RTBox11.Text)
       xlsheet.Cells(41, 8) = Trim(RTBox10.Text)
    '给单元格1行驶列赋值
'    xlBook.RunAutoMacros (xlAutoOpen) '运行EXCEL中的启动宏
xlsheet.PrintOut
  xlBook.Close (False)
  xlApp.Quit
  End If
End Sub