Dim Irow, Icol As Integer Dim Irowcount, Icolcount As Integer Dim Fieldlen1 As Integer '存字段长度值 Dim Fieldlen() 'Dim xlApp As Excel.Application 'Dim xlBook As Excel.Workbook 'Dim xlSheet As Excel.Worksheet Set xlApp = CreateObject("Excel.Application") Set xlBook = xlApp.Workbooks.Add Set xlSheet = xlBook.Worksheets(1) 'On Error GoTo excle With Rs_Temp .MoveLast If .RecordCount < 1 Then MsgBox ("没有记录!") Exit Sub End If '记录总数 Irowcount = .RecordCount '字段总数 Icolcount = .Fields.Count ReDim Fieldlen(Icolcount) .MoveFirst For Irow = 1 To Irowcount + 1
For Icol = 1 To Icolcount Select Case Irow '在Excel中的第一行加标题 Case 1 xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1).Name '将数组FIELDLEN()存为第一条记录的字段长 Case 2 If IsNull(.Fields(Icol - 1)) = True Then Fieldlen(Icol) = LenB(.Fields(Icol - 1).Name) '如果字段值为NULL,则将数组Filelen(Icol)的值设为标题名的宽度 Else Fieldlen(Icol) = LenB(.Fields(Icol - 1)) End If xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol) 'Excel列宽等于字段长 xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1) '向Excel的CellS中写入字段值 Case Else If IsNull(.Fields(Icol - 1)) Then Fieldlen(Icol) = LenB(.Fields(Icol - 1).Name) Else Fieldlen1 = LenB(.Fields(Icol - 1)) End If If Fieldlen(Icol) < Fieldlen1 Then xlSheet.Columns(Icol).ColumnWidth = IIf(Fieldlen1 > 255, 255, Fieldlen1) '表格列宽等于较长字段长 Fieldlen(Icol) = IIf(Fieldlen1 > 255, 255, Fieldlen1) '数组Fieldlen(Icol)中存放最大字段长度值 Else xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol) End If xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1) End Select Next If Irow > 2 Then If Not .EOF Then .MoveNext End If
Next '网格线 With xlSheet .Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Name = "黑体" '设标题为黑体字 .Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Bold = True '标题字体加粗 .Range(.Cells(1, 1), .Cells(Irow, Icol - 1)).Borders.LineStyle = xlContinuous '设表格边框样式 End With '*!* 页眉、填报单位、报表时间、单位 With xlSheet.PageSetup .LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称:" ' & Gsmc .CenterHeader = "&""楷体_GB2312,常规""业务数据综合查询表&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日 期:" .RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位:" .LeftFooter = "&""楷体_GB2312,常规""&10制表人:" .CenterFooter = "&""楷体_GB2312,常规""&10制表日期:" .RightFooter = "&""楷体_GB2312,常规""&10第&P页 共&N页" End With '显示表格 Dim ExclFileName As String ExclFileName = App.path & "\业务数据综合查询表.xls" If Dir(ExclFileName) <> "" Then Kill ExclFileName End If xlSheet.SaveAs (ExclFileName)
xlApp.Application.Visible = True '交还控制给Excel 'xlSheet.PrintPreview 'xlApp.Quit End With
这样做很快如果需要的话,我这里做了一个控件
QQ:38647302
For i = 1 To 6
.Range(.Cells(1, i), .Cells(2, i)).MergeCells = True
Next
.Cells(1, 1).Value = "贷款号"
.Cells(1, 2).Value = "项目名称"
.Cells(1, 3).Value = "币种"
.Cells(1, 4).Value = "累计到期" & vbCrLf & "应还本金"
.Cells(1, 5).Value = "累计到期" & vbCrLf & "应还利息"
.Cells(1, 6).Value = "合计"
.Range(.Cells(1, 7), .Cells(1, 9)).MergeCells = True
.Cells(1, 7).Value = "对财政部累计到期欠款余额"
.Cells(2, 7).Value = "本金"
.Cells(2, 8).Value = "利息"
.Cells(2, 9).Value = "合计"
.Range(.Cells(1, 10), .Cells(1, 11)).MergeCells = True
.Cells(1, 10).Value = "其中:"
.Cells(2, 10).Value = "上年末累计欠款"
.Cells(2, 11).Value = "本年新增欠款"
'以下代码填充实际数据
.Range(.Cells(9, 1), .Cells(10, 1)).MergeCells = True
.Cells(9, 1).Value = "合计"
.Cells(9, 3).Value = "USD"
.Cells(10, 3).Value = "RMB"
End With就是像上面这样一个一个格的填充。
Dim Irowcount, Icolcount As Integer
Dim Fieldlen1 As Integer
'存字段长度值
Dim Fieldlen()
'Dim xlApp As Excel.Application
'Dim xlBook As Excel.Workbook
'Dim xlSheet As Excel.Worksheet Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1) 'On Error GoTo excle
With Rs_Temp
.MoveLast If .RecordCount < 1 Then
MsgBox ("没有记录!")
Exit Sub
End If '记录总数
Irowcount = .RecordCount
'字段总数
Icolcount = .Fields.Count ReDim Fieldlen(Icolcount)
.MoveFirst For Irow = 1 To Irowcount + 1
For Icol = 1 To Icolcount
Select Case Irow
'在Excel中的第一行加标题
Case 1
xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1).Name
'将数组FIELDLEN()存为第一条记录的字段长
Case 2
If IsNull(.Fields(Icol - 1)) = True Then
Fieldlen(Icol) = LenB(.Fields(Icol - 1).Name)
'如果字段值为NULL,则将数组Filelen(Icol)的值设为标题名的宽度
Else
Fieldlen(Icol) = LenB(.Fields(Icol - 1))
End If xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)
'Excel列宽等于字段长
xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1)
'向Excel的CellS中写入字段值
Case Else
If IsNull(.Fields(Icol - 1)) Then
Fieldlen(Icol) = LenB(.Fields(Icol - 1).Name)
Else
Fieldlen1 = LenB(.Fields(Icol - 1))
End If If Fieldlen(Icol) < Fieldlen1 Then
xlSheet.Columns(Icol).ColumnWidth = IIf(Fieldlen1 > 255, 255, Fieldlen1)
'表格列宽等于较长字段长
Fieldlen(Icol) = IIf(Fieldlen1 > 255, 255, Fieldlen1)
'数组Fieldlen(Icol)中存放最大字段长度值
Else
xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)
End If xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1)
End Select
Next If Irow > 2 Then
If Not .EOF Then .MoveNext
End If
Next '网格线
With xlSheet
.Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Name = "黑体"
'设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Bold = True
'标题字体加粗
.Range(.Cells(1, 1), .Cells(Irow, Icol - 1)).Borders.LineStyle = xlContinuous
'设表格边框样式
End With '*!* 页眉、填报单位、报表时间、单位
With xlSheet.PageSetup
.LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称:" ' & Gsmc
.CenterHeader = "&""楷体_GB2312,常规""业务数据综合查询表&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日 期:"
.RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位:"
.LeftFooter = "&""楷体_GB2312,常规""&10制表人:"
.CenterFooter = "&""楷体_GB2312,常规""&10制表日期:"
.RightFooter = "&""楷体_GB2312,常规""&10第&P页 共&N页"
End With '显示表格
Dim ExclFileName As String
ExclFileName = App.path & "\业务数据综合查询表.xls"
If Dir(ExclFileName) <> "" Then
Kill ExclFileName
End If
xlSheet.SaveAs (ExclFileName)
xlApp.Application.Visible = True
'交还控制给Excel
'xlSheet.PrintPreview
'xlApp.Quit
End With