[转帖]CSDN-文档中心-有关office中的VB(VBA)编程应用

DC.Direct

标题 Excel 的VB编程 选择自 hh_bj 的 Blog 关键字 Excel 的VB编程 出处 CSDN - 文档中心 - Visual Basic Excel编程碰到的第一个问题是表头。有时表头的形式比较复杂，需要横向或纵向合并单元格。请放心，只要没有斜杠，Excel都能应付得了。

---- 例如合并A2~A5这4个单元格，你录制的宏代码会是这样：

Range("A2:A5").Select

With Selection

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlBottom

.WrapText = False

.Orientation = 0

.AddIndent = False

.ShrinkToFit = False

.MergeCells = False

End With

Selection.Merge ---- 而自己编程只要一句 Range.(“A2:A5”).mergecells=True 就可以解决问题。

---- 表头形式定了，再就是表头的内容。如果单元格中的文本长度超过了列宽，往往只能显示部分内容，行尾那一格的内容则会“越境”进入右边那个空白单元格，很不美观。这个问题可以通过在程序中设置列宽加以解决。

---- Columns(14).columnwidth=12 ‘设置第14列列宽为12（缺省列宽为8.38）

---- 如果你不愿意劳神去逐列估计实际所需的列宽，干脆来一行

---- Columns(“a:i”).autofit ‘a到i列自动调整列宽

---- 让Excel随机应变吧。

---- 但也许你不喜欢这种方法，认为表头撑大了列宽，弄得浏览一张小表格还得向右滚动，太不方便了。要是能保持默认列宽，让文本自动换行就好了。没问题，Excel包你满意。

---- Rows(3).WrapText=True ‘让第三行各单元格中的文本自动换行

---- 不过你最好再加一句 Rows(3) .VerticalAlignment = xlTop 让表头自动向上对齐，这样比较符合习惯。

---- 你还可以给表头打上底色，让你的读者不至于看了打哈欠。

---- Rows(2). Interior .ColorIndex = 5 '设置第2行底色为蓝色

---- 再给表格的标题上色，这样更醒目一点。

---- Rows(1).Font.ColorIndex=4

---- 表头完成后该填数据了，一个一个地填实在是太慢了，如果你的数据是存放在一个二维数组中，那问题就简单多了。

Dim Data(3,4)

………… ‘数据处理

Range(“a2:d4”).Value=Data

---- 这样可以一次填入一个表的所有数据，够快了吧！不过提醒一句，Range对象大小最好与数组匹配，小了无法显示所有数据，大了则会在空白单元格只填入“N/A”表示没有取得数据。

---- 如果需要在结果中显示多个同样规格的数据表，想在Range对象中加入循环变量，这也好办。

Dim cell11,cell2

Dim Data(3,4)

…………

For I =1 to 40

………… ‘数据处理

Set cell1=Worksheets("Sheet1").Cells(5*I-4,1)

Set cell2=Worksheets("Sheet1").Cells(5*I-2,4)

Worksheets("Sheet1").Range(cell1,cell2).value=Data

Next I

---- 表格填完了，现在该打表格线了，以下几条语句可以满足你的要求：

With Worksheets("Sheet1").Range(cell1,cell2).borders

.LineStyle=xlContinuous

.weight=xlThin

End With

作者Blog：http://blog.csdn.net/hh_bj/

[em08]

DC.Direct

标题 VB与数据库应用一例----生成EXCEL表 选择自 cocoboy79 的 Blog 关键字 VB与数据库应用一例----生成EXCEL表 出处 CSDN - 文档中心 - Visual Basic

小生初学炸练，总结了以下一个方法，因为时间有限，所以没有太多检查程序，难免有BUG，但是关键功能没有问题。这测试过了，嘿嘿。

这个程序可以将下图表格中(MSHFLEXGRID控件)的 数据生成一个EXCEL表，这样可以省去用VB 来编写打印排版程序的麻烦。想一想自已动 手用VB或DELPHI写一个像EXCEL的排版功能 一样的东东，是多么的恐怖!!。所以嘿嘿。。

原程序下载： 因为我用的是ACCESS2000的样本数据库--- NorthWind.mdb 所以安了OFFICE2000的可以 下载下面这个：(不代NorthWind.mdb，下载后请将 Office2000里那个COPY到这个程序的目录中就行) http://go.163.com/~chunpeng/Project/PrintExcela.zip

没有NorthWind.mdb的可以下载这个： http://go.163.com/~chunpeng/Project/PrintExcel.zip

高手可以直接看下面，如果用VB做过数据库应 用的朋友给点意见，这种方法我曾在多个MIS 系统中见过，只不过生成的是WORD文档。这是 一种比较典型的方法。

Public WithEvents rs As ADODB.Recordset Dim conn As ADODB.Connection Dim myPanel As Panel

Private Sub Form_Load() Set rs = New ADODB.Recordset Set conn = New ADODB.Connection conn.CursorLocation = adUseClient conn.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" + App.Path + "\northwind.mdb;" rs.Open "select *from 产品", conn, adOpenStatic, adLockOptimistic Set MSgrid1.DataSource = rs

StatusBar1.Panels.Clear Set myPanel = StatusBar1.Panels.Add(, "Record") myPanel.AutoSize = sbrContents myPanel.Text = "总共有" & " " & rs.RecordCount & " " & "条记录" End Sub

Private Sub Form_Resize() With MSgrid1 .Left = 0 .Top = Toolbar1.Height .Width = Me.ScaleWidth - 10 .Height = Me.ScaleHeight - (StatusBar1.Height + 700) End With

End Sub

Private Sub Print_cmd_Click() Form2.Show Dim myExcel As New Excel.Application, i, j, k As Integer, col As String With myExcel On Error GoTo Excle .Application.Visible = False .Workbooks.Add

'***********画字段************ j = 0 'Example: B2 ----G2 '列 本程序从B列,和第2行开始 For i = 66 To (66 + rs.Fields.Count - 1) '从RS中头一个字段到最后一个 col = Chr(i) & "2" 'Chr(66)就是B 'Debug.Print col Range(col).Select ActiveCell.FormulaR1C1 = rs.Fields(j).Name ' j = j + 1 Next i '**************************** '*************以先横后竖顺序画表*************** k = 0 rs.MoveFirst DoEvents For j = 3 To 3 + rs.RecordCount '本程序从B3开始，所以用3 k = 0 For i = 66 To (66 + rs.Fields.Count - 1) col = Chr(i) & CStr(j) '得到目标表格的值如 C3 Range(col).Select ActiveCell.FormulaR1C1 = rs.Fields(k) k = k + 1 Next i On Error Resume Next Form2.Probar.Value = Form2.Probar.Value + 1 rs.MoveNext

If rs.EOF = True Then Unload Form2 .Application.Visible = True End If

Next j '************************************ End With Exit Sub

Excle: MsgBox ("您没有安装EXCLE2000，请先安装EXCEL2000") End Sub

作者Blog：http://blog.csdn.net/cocoboy79/

[em08]

DC.Direct

标题 VB中使用EXCEL输出 选择自 mi6236 的 Blog 关键字 VB中使用EXCEL输出 出处 CSDN - 文档中心 - Visual Basic

Private Sub cmdSwatch_Click() Dim xls As excel.Application Dim xlbook As excel.Workbook 'On Error GoTo exlError Dim i As Integer If Dir(Text1.Text) <> "" Then '此目录下如有同名文件给出提示,并作相应处理 If MsgBox("文件已存在，是否覆盖！", vbYesNo + vbQuestion, "另存为工程造价文件") = vbNo Then Exit Sub Else Kill (Text1.Text) '删除文件 End If End If

'************打开工作表*************** Set xls = New excel.Application xls.Visible = True Set xlbook = xls.Workbooks.Add '********************************* For i = 0 To 14 If Check2(i).Value = vbChecked Then Select Case i Case 8 ToExcelJDanJiaSum.ToExcelJDanJiaSum xlbook, xls Case 9 ToExcelADanJiaSum.ToExcelADanJiaSum xlbook, xls Case 10 ToExcelCailiao.ToExcelCailiao xlbook, xls Case 11 ToExcelTsf.ToExcelTsf xlbook, xls Case 12 ToExcelZgcl.ToExcelZgcl xlbook, xls End Select End If Next For i = 0 To 6 If Check3(i).Value = vbChecked Then Select Case i Case 0 ToExcelMan.ToExcelMan xlbook, xls Case 1 ToExcelFSD_CL.ToExcelFSD_CL xlbook, xls Case 2 ToExcelHNT.ToExcelHNT xlbook, xls Case 3 ToExcelZsf.ToExcelZsf xlbook, xls Case 4 ToExcelJingChang.ToExcelJingChang xlbook, xls Case 5 ToExcelJDanJia.ToExcelJDanJia xlbook, xls Case 6 ToExcelADanJia.ToExcelADanJia xlbook, xls End Select End If Next xlbook.SaveAs Text1.Text '保存EXCEL文件 '***************************关闭EXCEL对象******************* If Check1.Value = vbChecked Then xlbook.Close xls.Quit End If Set xlbook = Nothing Set xls = Nothing Exit Sub 'exlError: ' MsgBox Err.Description, vbOKOnly + vbCritical, "警告" End Sub

Option Explicit Public Sub ToExcelZgcl(ByRef xlbook, ByRef xls) '输出总工程量 Dim con As New ADODB.Connection Dim rst_gcl As New ADODB.Recordset Dim rst_qm As New ADODB.Recordset '**************************连接数据库**************************************** con.CursorLocation = adUseClient con.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strConnection & ";Persist Security Info=False" con.Open rst_gcl.Open "zonggcl", con, adOpenKeyset, adLockOptimistic, adCmdTable '打开工程量汇总表 If Not (rst_gcl.BOF And rst_gcl.EOF) Then rst_gcl.MoveFirst End If rst_qm.Open "qianming", con, adOpenKeyset, adLockOptimistic, adCmdTable '打开签名表 rst_qm.MoveFirst '****************************工作表初使化*********************************** Dim xlsheet As excel.Worksheet Set xlsheet = xlbook.Sheets.Add '添加一张工作表 xlsheet.Name = "工程量汇总" xls.ActiveSheet.PageSetup.Orientation = xlLandscape '纸张设置为横向 xlsheet.Columns("a:j").Font.Size = 10 xlsheet.Columns("a:j").VerticalAlignment = xlVAlignCenter '垂直居中 xlsheet.Columns(1).HorizontalAlignment = xlHAlignCenter '1列水平居中对齐 xlsheet.Columns(1).ColumnWidth = 8 xlsheet.Columns(2).HorizontalAlignment = xlHAlignLeft xlsheet.Columns(2).ColumnWidth = 26 xlsheet.Columns("c:j").HorizontalAlignment = xlHAlignRight xlsheet.Columns("c:j").ColumnWidth = 10 xlsheet.Columns("c:j").NumberFormatLocal = "0.00_ " '3到10列保留两位小数 '***************************写入标头************************************* xlsheet.Rows(1).RowHeight = 40 xlsheet.Range(xlsheet.Cells(1, 1), xlsheet.Cells(1, 10)).MergeCells = True xlsheet.Cells(1, 1).Value = "工程量汇总" xlsheet.Cells(1, 1).Font.Size = 14 xlsheet.Cells(1, 1).Font.Bold = True xlsheet.Rows(2).RowHeight = 18 xlsheet.Rows(2).HorizontalAlignment = xlHAlignCenter xlsheet.Cells(2, 1).Value = "序号" xlsheet.Cells(2, 2).Value = "工程项目及名称" xlsheet.Cells(2, 3).Value = "土方开挖(m3)" xlsheet.Cells(2, 4).Value = "石方开挖(m3)" xlsheet.Cells(2, 5).Value = "土方回填(m3)" xlsheet.Cells(2, 6).Value = "洞挖石方(m3)" xlsheet.Cells(2, 7).Value = "砼浇筑(m3)" xlsheet.Cells(2, 8).Value = "钢筋制安(t)" xlsheet.Cells(2, 9).Value = "砌石工程(m3)" xlsheet.Cells(2, 10).Value = "灌浆工程(m)" xls.ActiveSheet.PageSetup.PrintTitleRows = "$1:$2" '固定表头 '***************************写入内容************************* Dim i As Integer i = 3 'i控制行 Dim j As Integer 'j控制列 Dim countpage As Integer countpage = 0 '控制页 Do While Not rst_gcl.EOF xlsheet.Rows(i).RowHeight = 18 '控制行高 For j = 1 To 10 xlsheet.Cells(i, j) = rst_gcl.Fields(j) '将工程理库中的一条记录的第一个字段写入工作表中 Next '每18行为一页，如果数据超出一页时进行特殊处理 If i > 18 Then xls.ActiveWindow.SmallScroll Down:=1 '活动窗口内容向下滚动1行 End If If i Mod 18 = 0 Then If countpage = 0 Then xlsheet.Range(xlsheet.Cells(2, 1), xlsheet.Cells(i, 10)).Borders.LineStyle = xlContinuous '首页加边框 Else xlsheet.Range(xlsheet.Cells(23 + (countpage - 1) * 18, 1), xlsheet.Cells(i, 10)).Borders.LineStyle = xlContinuous '中间页加边框 End If i = i + 2 '加一条空行 '******************************在非尾页写入签名************************************** xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = True xlsheet.Cells(i, 1).Value = Space(64) & rst_qm.Fields(0) xlsheet.Rows(i).RowHeight = 30 i = i + 1 '换行 xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = True xlsheet.Cells(i, 1).Value = Space(50) & rst_qm.Fields(1) xlsheet.Rows(i).RowHeight = 15 i = i + 1 xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = True xlsheet.Cells(i, 1).Value = Space(55) & rst_qm.Fields(2) xlsheet.Rows(i).RowHeight = 30 '**************************************************************************** xlsheet.HPageBreaks.Add (xlsheet.Rows(i + 1)) '添加分页符 countpage = countpage + 1 '换页 End If i = i + 1 rst_gcl.MoveNext Loop xlsheet.Range(xlsheet.Cells(23 + (countpage - 1) * 18, 1), xlsheet.Cells(i - 1, 10)).Borders.LineStyle = xlContinuous '尾页加边框 i = i + 1 '加入一空行 '*********************************在尾页加签名*************************************** xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = True xlsheet.Cells(i, 1).Value = Space(64) & rst_qm.Fields(0) xlsheet.Rows(i).RowHeight = 30 i = i + 1 '换行 xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = True xlsheet.Cells(i, 1).Value = Space(50) & rst_qm.Fields(1) xlsheet.Rows(i).RowHeight = 15 i = i + 1 xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = True xlsheet.Cells(i, 1).Value = Space(55) & rst_qm.Fields(2) xlsheet.Rows(i).RowHeight = 30 '*********************************************************************************** xls.ActiveWindow.View = xlPageBreakPreview '分页预览 xls.ActiveWindow.Zoom = 100 If con.State = adStateOpen Then rst_gcl.Close rst_qm.Close Set rst_gcl = Nothing Set rst_qm = Nothing con.Close Set con = Nothing End If Set xlsheet = Nothing End Sub

Option Explicit

Public Sub ToExcelTsf(ByRef xlbook, ByRef xls) Dim con As New ADODB.Connection Dim rst_tsf As New ADODB.Recordset Dim rst_qm As New ADODB.Recordset '**********************************连接数据库************************ con.CursorLocation = adUseClient con.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strConnection & ";Persist Security Info=False" con.Open rst_tsf.Open "tdefeiyong", con, adOpenKeyset, adLockOptimistic, adCmdTable If Not (rst_tsf.BOF And rst_tsf.EOF) Then rst_tsf.MoveFirst End If rst_qm.Open "qianming", con, adOpenKeyset, adLockOptimistic, adCmdTable rst_qm.MoveFirst '*********************************工作表初使化********************************** Dim xlsheet As excel.Worksheet Set xlsheet = xlbook.Sheets.Add xlsheet.Name = "机械台时、组时费汇总表" xlsheet.Columns(1).ColumnWidth = 5 xlsheet.Columns(2).ColumnWidth = 20 xlsheet.Columns(3).ColumnWidth = 7 xlsheet.Columns(4).ColumnWidth = 7 xlsheet.Columns(5).ColumnWidth = 7 xlsheet.Columns(6).ColumnWidth = 7 xlsheet.Columns(7).ColumnWidth = 7 xlsheet.Columns(8).ColumnWidth = 7 xlsheet.Columns(9).ColumnWidth = 7 xlsheet.Columns("A:I").Font.Size = 9 xlsheet.Columns("A:I").VerticalAlignment = xlVAlignCenter '垂直居中 xlsheet.Columns(1).HorizontalAlignment = xlHAlignCenter '1列水平居中对齐 xlsheet.Columns(2).HorizontalAlignment = xlHAlignLeft '2列水平左对齐 '******************************写入标头************************************ xlsheet.Rows(1).RowHeight = 35 xlsheet.Range(xlsheet.Cells(1, 1), xlsheet.Cells(1, 9)).MergeCells = True xlsheet.Cells(1, 1).Font.Size = 14 xlsheet.Cells(1, 1).Font.Bold = True xlsheet.Cells(1, 1).Value = "机械台时、组时费汇总表" xlsheet.Cells(2, 9).Value = "单位：元" xlsheet.Range(xlsheet.Cells(3, 1), xlsheet.Cells(5, 1)).MergeCells = True xlsheet.Cells(3, 1).Value = "编号" xlsheet.Range(xlsheet.Cells(3, 2), xlsheet.Cells(5, 2)).MergeCells = True xlsheet.Cells(3, 2).Value = "机械名称" xlsheet.Range(xlsheet.Cells(3, 3), xlsheet.Cells(5, 3)).MergeCells = True xlsheet.Cells(3, 3).Value = "台时费" xlsheet.Range(xlsheet.Cells(3, 4), xlsheet.Cells(3, 9)).MergeCells = True xlsheet.Cells(3, 4).Value = "其 中" xlsheet.Range(xlsheet.Cells(3, 3), xlsheet.Cells(5, 3)).MergeCells = True xlsheet.Cells(3, 3).Value = "台时费" xlsheet.Range(xlsheet.Cells(4, 4), xlsheet.Cells(5, 4)).MergeCells = True xlsheet.Cells(4, 4).Value = "折旧费" xlsheet.Range(xlsheet.Cells(4, 5), xlsheet.Cells(5, 5)).MergeCells = True xlsheet.Cells(4, 5).Value = "修理替换费" xlsheet.Range(xlsheet.Cells(4, 6), xlsheet.Cells(5, 6)).MergeCells = True xlsheet.Cells(4, 6).Value = "安拆费" xlsheet.Range(xlsheet.Cells(4, 7), xlsheet.Cells(5, 7)).MergeCells = True xlsheet.Cells(4, 7).Value = "人工费" xlsheet.Range(xlsheet.Cells(4, 8), xlsheet.Cells(5, 8)).MergeCells = True xlsheet.Cells(4, 8).Value = "燃料费" xlsheet.Range(xlsheet.Cells(4, 9), xlsheet.Cells(5, 9)).MergeCells = True xlsheet.Cells(4, 9).Value = "其他费" xlsheet.Range(xlsheet.Cells(1, 1), xlsheet.Cells(5, 9)).HorizontalAlignment = xlHAlignCenter xls.ActiveSheet.PageSetup.PrintTitleRows = "$1:$5" '固定表头 '****************************************写入内容************************************* Dim i As Integer i = 6 Do While Not rst_tsf.EOF xlsheet.Cells(i, 1).Value = rst_tsf.Fields("nn") xlsheet.Cells(i, 2).Value = rst_tsf.Fields("name") xlsheet.Cells(i, 3).Value = rst_tsf.Fields("price") xlsheet.Cells(i, 4).Value = rst_tsf.Fields("zhejiu") xlsheet.Cells(i, 5).Value = rst_tsf.Fields("xiuli") xlsheet.Cells(i, 6).Value = rst_tsf.Fields("anchai") xlsheet.Cells(i, 7).Value = rst_tsf.Fields("rengong") xlsheet.Cells(i, 8).Value = rst_tsf.Fields("dongli") xlsheet.Cells(i, 9).Value = rst_tsf.Fields("qita") If i > 22 Then xls.ActiveWindow.SmallScroll Down:=1 '活动窗口内容向下滚动1行 End If i = i + 1 rst_tsf.MoveNext Loop xlsheet.Range(xlsheet.Cells(6, 3), xlsheet.Cells(i - 1, 9)).NumberFormatLocal = "0.00_ " '保留两位小数 '*********************************添加边框********************************** xlsheet.Range(xlsheet.Cells(3, 1), xlsheet.Cells(i - 1, 9)).Borders.LineStyle = xlContinuous '****************************************************************************** xls.ActiveSheet.PageSetup.BottomMargin = Application.InchesToPoints(2.2) '设置下侧面边距 xls.ActiveSheet.PageSetup.FooterMargin = Application.InchesToPoints(1) '设置页脚高 xls.ActiveSheet.PageSetup.CenterFooter = "&10" & rst_qm.Fields(0) & Chr(10) & Chr(10) & rst_qm.Fields(1) & Chr(10) & Chr(10) & rst_qm.Fields(2) '加页脚 xls.ActiveWindow.View = xlPageBreakPreview '分页预览 xls.ActiveWindow.Zoom = 100 '***************************关闭记录集******************* If con.State = adStateOpen Then rst_tsf.Close rst_qm.Close Set rst_tsf = Nothing Set rst_qm = Nothing con.Close Set con = Nothing End If Set xlsheet = Nothing End Sub

精彩的后续 作者Blog：http://blog.csdn.net/mi6236/

[em08]

DC.Direct

标题 实现货币金额中文大写转换的程序 选择自 northwolves 的 Blog 关键字 货币 大写 中文 出处 CSDN - 文档中心 - Visual Basic

今天整理文件时发现了以前写的货币金额中文转换（转换一亿亿元以下数目的货币）的代码，帖出来与大家共享：

Function daxie(money As String) As String ' Dim x As String, y As String Const zimu = ".sbqwsbqysbqwsbq" '定义位置代码 Const letter = "0123456789sbqwy.zjf" '定义汉字缩写 Const upcase = "零壹贰叁肆伍陆柒捌玖拾佰仟萬億圆整角分" '定义大写汉字 Dim temp As String temp = money If InStr(temp, ".") > 0 Then temp = Left(temp, InStr(temp, ".") - 1)

If Len(temp) > 16 Then MsgBox "数目太大，无法换算！请输入一亿亿以下的数字", 64, "错误提示": Exit Function '只能转换一亿亿元以下数目的货币！

x = Format(money, "0.00") '格式化货币 y = "" For i = 1 To Len(x) - 3 y = y & Mid(x, i, 1) & Mid(zimu, Len(x) - 2 - i, 1) Next If Right(x, 3) = ".00" Then y = y & "z" '***元整 Else y = y & Left(Right(x, 2), 1) & "j" & Right(x, 1) & "f" '*元*角*分 End If y = Replace(y, "0q", "0") '避免零千(如：40200肆萬零千零贰佰) y = Replace(y, "0b", "0") '避免零百(如：41000肆萬壹千零佰) y = Replace(y, "0s", "0") '避免零十(如：204贰佰零拾零肆)

Do While y <> Replace(y, "00", "0") y = Replace(y, "00", "0") '避免双零(如：1004壹仟零零肆) Loop y = Replace(y, "0y", "y") '避免零億(如：210億 贰佰壹十零億) y = Replace(y, "0w", "w") '避免零萬(如：210萬 贰佰壹十零萬) y = IIf(Len(x) = 5 And Left(y, 1) = "1", Right(y, Len(y) - 1), y) '避免壹十(如：14壹拾肆；10壹拾) y = IIf(Len(x) = 4, Replace(y, "0.", ""), Replace(y, "0.", ".")) '避免零元(如：20.00贰拾零圆；0.12零圆壹角贰分)

For i = 1 To 19 y = Replace(y, Mid(letter, i, 1), Mid(upcase, i, 1)) '大写汉字 Next daxie = y End Function

Private Sub Command3_Click() Debug.Print daxie("6218212212309322.3238") ' return: 陆仟贰佰壹拾捌萬贰仟壹佰贰拾贰億壹仟贰佰叁拾萬玖仟叁佰贰拾贰圆叁角贰分 End Sub

作者Blog：http://blog.csdn.net/northwolves/

[em08]

DC.Direct

标题 如何快速导出数据库为EXCEL文档(另一种方法) 选择自 limitworld 的 Blog 关键字 导出 出处 CSDN - 文档中心 - Visual Basic

在网上的导出为 EXCEL文档的方法大概是这样的

Dim i As Integer, j As Integer Dim myexcel As New Excel.Application Dim mybook As New Excel.Workbook Dim mysheet As New Excel.Worksheet Set mybook = myexcel.Workbooks.Add '添加一个新的BOOK Set mysheet = mybook.Worksheets.Add '添加一个新的SHEET ' For i = 1 To myres.RecordCount ' For j = 1 To myres.Fields.Count ' mysheet.Cells(i, j) = myres.Fields.Item(j - 1).Value ' If (i * j) Mod 500 = 0 Then ' DoEvents ' End If ' Next j ' myres.MoveNext ' Next i myexcel.Visible = True mybook.SaveAs (m_ExcelName) '保存文件

这中方法没什么错误,但是如果数据量很大的话,麻烦就来了,出现程序长时间不响应

关键是循环,下给出我的代码

假设定义的记录名为myres

Dim myexcel As New Excel.Application Dim mybook As New Excel.Workbook Dim mysheet As New Excel.Worksheet Set mybook = myexcel.Workbooks.Add '添加一个新的BOOK Set mysheet = mybook.Worksheets.Add '添加一个新的SHEET myexcel.visible=true

mysheet.Cells.CopyFromRecordset myres

mybook.SaveAs (m_ExcelName) '保存文件

利用这个代码可以大大的缩短导出时间,8000多个纪录用第一种方法大概需要2分多

而用第二种方法只大概要4秒,可以亲自试验一下,上述结果测试平台为WIN98+EXCEL2000

作者Blog：http://blog.csdn.net/limitworld/

[em08]