怪!VB导出数据EXCEL连续操作竟不能设置格式
用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 = Nothing
end sub
谢谢!
[解决办法]
代码完全相同吗
[解决办法]
学习
[解决办法]
理论上不会这样的，请确保其它地方都正确。
把On Error Resume Next去掉再看。
[解决办法]
就是有问题才会这样，你把On Error Resume Next去掉程序就执行不了了，不信试看看。
[解决办法]
实在不喜欢 On Error Resume Next
[解决办法]
用代码实现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
