vb导出数据到Excel

如何把MSHFlexGrid里的数据导出至Excel？用Adodc1做了查询语句，结果显示在一个MSHFlexGrid里面。

现在要求做一个按钮（Command1），点击它就把MSHFlexGrid里显示的数据导出至Excel表中。

就是一点这个按钮，就会自动打开Excel，然后数据就已经进去了，方便编辑和打印。

要求：代码详细，直接复制到Command1下就能用。

这块我不懂，所以不要搞什么子程序调用之类的，要有子程序也给直接调用好。

直接复制代码成功后，再追加100分。

把这个弄完工程就结了，再不用受罪了，哈哈！以下是精简后的代码,不清楚你工作中的一些细节,所以如有问题与我讨论Private Sub Command1_Click()MSFlexGrid1.Redraw = False '关闭表格重画，加快运行速度Set xlApp = CreateObject("Excel.Application") '创建EXCEL对象Set xlBook = xlApp.Workbooks.Open(App.Path & "\对账模板.xls") '打开已经存在的EXCEL 工件簿文件xlApp.Visible = True '设置EXCEL对象可见（或不可见）Set xlsheet = xlBook.Worksheets("Sheet1") '设置活动工作表For R = 0 To MSFlexGrid1.Rows - 1 '行循环For C = 0 To MSFlexGrid1.Cols - 1 '列循环MSFlexGrid1.Row = RMSFlexGrid1.Col = CxlBook.Worksheets("Sheet1").Cells(R + 1, C + 1) = MSFlexGrid1.Text '保存到EXCEL Next CNext RMSFlexGrid1.Redraw = True'xlsheet.PrintOut '打印工作表xlApp.DisplayAlerts = False '不进行安全提示'xlBook.Close (False) '关闭工作簿Set xlsheet = NothingSet xlBook = NothingxlApp.QuitSet xlApp = NothingEnd Sub下面的代码就也能导出到EXCELDim xlApp As Excel.ApplicationDim xlBook As Excel.WorkbookDim xlSheet As Excel.WorksheetDim i As Long, J As LongOn Error GoTo ErrorHandleSet xlApp = CreateObject( "Excel.Application ")Set xlBook = xlApp.Workbooks.AddSet xlSheet = xlBook.Worksheets(1)For i = 0 To MHFGrid.Rows - 1For J = 0 To MHFGrid.Cols - 1xlSheet.Cells(i + 1, J + 1).Value = MHFGrid.TextMatrix(i, J)Next JNext ixlSheet.Application.Visible = TrueSet xlSheet = NothingSet xlBook = NothingSet xlApp = NothingExit SubErrorHandle:MsgBox "错误：" & Err.Number & vbCrLf & Err.Description, vbOKOnly, "运行错误"如何将表中的数据导出到电子表格中作者：施进兵有很多方法都可将数据库中某个表的数据导出到电子表格中，例如通过创建Access.Application，可以利用Access本身的导出功能实现将表中的数据导出到电子表格中。

vba copyfromrecordsetVBA CopyFromRecordset是一种用于将ADO Recordset中的数据复制到Excel工作表中的方法。

它可以有效地将大量数据从数据库中导入到Excel工作表中，而无需手动输入每个单元格的数据。

本文将介绍VBA CopyFromRecordset的用法、语法和示例。

一、VBA CopyFromRecordset的用法VBA CopyFromRecordset方法是Range对象的一个方法，它可以将ADO Recordset对象中的数据复制到指定范围内。

它有两个参数：Source和Destination。

Source是指要复制数据的ADO Recordset 对象，而Destination则是指要将数据复制到哪个范围内。

二、VBA CopyFromRecordset的语法下面是VBA CopyFromRecordset方法的语法：Range.CopyFromRecordset(Source As Object, [MaxRows], [MaxColumns])其中，- Range：必需。

要将数据复制到其中的范围。

- Source：必需。

要从中复制数据的ADO Recordset对象。

- MaxRows：可选。

要从记录集复制多少行。

如果未指定，则会复制整个记录集。

- MaxColumns：可选。

要从记录集复制多少列。

如果未指定，则会复制整个记录集。

三、VBA CopyFromRecordset示例下面是一个简单的示例，演示如何使用VBA CopyFromRecordset方法从Access数据库中导入数据到Excel工作表中。

首先，需要创建一个连接字符串来连接Access数据库：Dim conn As New ADODB.ConnectionDim rs As New ADODB.RecordsetDim strConn As StringstrConn = "Provider=Microsoft.ACE.OLEDB.12.0;DataSource=C:\MyDatabase.accdb;Persist Security Info=False;"然后，使用连接字符串打开数据库连接：conn.Open strConn接下来，创建一个SQL查询语句来从数据库中检索数据：strSQL = "SELECT * FROM MyTable"然后，使用Recordset对象执行查询并将结果存储在Recordset对象中：rs.Open strSQL, conn最后，使用CopyFromRecordset方法将Recordset对象中的数据复制到Excel工作表中的指定范围内：Range("A1").CopyFromRecordset rs完整的VBA代码如下所示：Sub ImportDataFromAccess()Dim conn As New ADODB.ConnectionDim rs As New ADODB.RecordsetDim strSQL As StringDim strConn As String'Create connection string to connect to Access databasestrConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\MyDatabase.accdb;Persist Security Info=False;"'Open database connection using the connection stringconn.Open strConn'Create SQL query to retrieve data from databasestrSQL = "SELECT * FROM MyTable"'Execute query and store results in Recordset objectrs.Open strSQL, conn'Copy data from Recordset object to Excel worksheet range Range("A1").CopyFromRecordset rsEnd Sub四、总结VBA CopyFromRecordset方法是一种非常有用的方法，可以将大量数据从数据库中导入到Excel工作表中，而无需手动输入每个单元格的数据。

一、导入到Xls文件并打印Sub OnLButtonUp(ByVal Item, ByVal Flags, ByVal x, ByVal y)Dim a,fsoa=HMIRuntime.Tags("fileName").ReadSet fso = CreateObject("scripting.filesystemobject")If fso.FileExists("C:\Model.xls") ThenDim objExcelAppSet objExcelApp = CreateObject("Excel.Application")objExcelApp.Visible = FalseobjExcelApp.Workbooks.Open "C:\Model.xls"objExcelApp.Cells(2, 3).Value = HMIRuntime.Tags("NewTag1_1").read objExcelApp.Cells(4, 5).Value = HMIRuntime.Tags("NewTag1_2").read objExcelApp.Cells(6, 7).Value = HMIRuntime.Tags("NewTag1_3").read objExcelApp.Cells(8, 9).Value = HMIRuntime.Tags("NewTag1_4").readobjExcelApp.Cells(10, 11).Value = HMIRuntime.Tags("NewTag1_5").read objExcelApp.ActiveWorkbook.SaveAs("C:\Report\"&CStr(a)&".xls")objExcelApp.ActiveWorkbook.PrintOutobjExcelApp.Workbooks.CloseobjExcelApp.QuitSet objExcelApp = NothingMsgBox "文件已经成功导出/Export Successful"ElseMsgBox "Excel模板文件不存在"End ifEnd Sub二、从Xls文件导入或者查询Sub OnLButtonUp(Byval Item, Byval Flags, Byval x, Byval y) Dim a,fsoa=HMIRuntime.Tags("FileName").ReadSet fso = CreateObject("scripting.filesystemobject")If fso.FileExists("C:\Report\"&CStr(a)&".xls") ThenDim objExcelAppSet objExcelApp = CreateObject("Excel.Application") objExcelApp.Visible = FalseobjExcelApp.Workbooks.Open "C:\Report\"&CStr(a)&".xls"HMIRuntime.Tags("NewTag1_1").Write objExcelApp.Cells(2, 3).Value HMIRuntime.Tags("NewTag1_2").Write objExcelApp.Cells(4, 5).Value HMIRuntime.Tags("NewTag1_3").Write objExcelApp.Cells(6, 7).Value HMIRuntime.Tags("NewTag1_4").Write objExcelApp.Cells(8, 9).ValueHMIRuntime.Tags("NewTag1_5").Write objExcelApp.Cells(10, 11).Value objExcelApp.ActiveWorkbook.SaveobjExcelApp.Workbooks.CloseobjExcelApp.QuitSet objExcelApp = NothingMsgBox "导入数据成功/Import Successful"ElseMsgBox "文件不存在/file is not existing"End ifEnd Sub3、WinCC如何实现带确认的按钮操作网上多是介绍C脚本实现的方法,其实VB脚本的实现更简单,代码如下:Sub OnLButtonUp(Byval Item, Byval Flags, Byval x, Byval y) If MsgBox("提示内容",1,"提示标题")=1 ThenHMIRuntime.Tags("TestTag").Write 1ElseHMIRuntime.Tags("TestTag").Write 0End IfEnd Sub说明MsgBox("提示内容",1,"提示标题")中的1为消息窗口中按钮的类型0=vbOKonly1=vbOKCancel2=vbAbortRetryIgnore3=vbYesNoCancel4=vbYesNo一、将WinCC变量导出到TEXT文件Sub OnLButtonUp(ByVal Item, ByVal Flags, ByVal x, ByVal y) Dim fso,FileDim aa=HMIRuntime.Tags("FileName").ReadConst ForWriting = 2Set fso = CreateObject("Scripting.FileSystemObject")Set File = fso.OpenTextFile("D:\Export&Import\"&CStr(a)&".txt", ForWriting, True) File.WriteLine(HMIRuntime.Tags("Var_1").read)File.WriteLine(HMIRuntime.Tags("Var_2").read)File.WriteLine(HMIRuntime.Tags("Var_3").read)File.WriteLine(HMIRuntime.Tags("Var_4").read)file.WriteLine(HMIRuntime.Tags("Var_5").read)File.CloseMsgBox "文件已经成功导出/Export Successful"End Sub二、从TXT文件中读取数据到WinCC变量Sub OnLButtonUp(ByVal Item, ByVal Flags, ByVal x, ByVal y)Dim fsoDim txtfileDim aa=HMIRuntime.Tags("FileName").ReadSet fso = CreateObject("scripting.filesystemobject")If fso.FileExists("D:\\Export&Import\\"&CStr(a)&".txt") ThenSet txtfile = fso.OpenTextFile("D:\\Export&Import\\"&CStr(a)&".txt") HMIRuntime.Tags("Var_1").Write txtfile.ReadLineHMIRuntime.Tags("Var_2").Write txtfile.ReadLineHMIRuntime.Tags("Var_3").Write txtfile.ReadLineHMIRuntime.Tags("Var_4").Write txtfile.ReadLineHMIRuntime.Tags("Var_5").Write txtfile.ReadLineMsgBox "导入数据成功/Import Successful"txtfile.CloseElseMsgBox "文件不存在/File is not existing"End ifEnd Sub。

ExcelVBA——如何从excel中导出数据到另⼀个excel表格1Function MyOutPut(ByVal FileName As String, ByVal col As Integer, ByVal Row As Long, ByVal sheet As Worksheet)2'/********************************************/3'参数1 ⽂件名4'参数2 结束列号5'参数3 起始⾏号6'参数4 ⼯作表指针7'/********************************************/8'9'输出整理好的表格10 Application.ScreenUpdating = False'关闭表格公式的⾃动刷新11'StartTime = Timer '记录开始运⾏时间12Dim endline As Long13Dim name As String14Dim myCol As Integer15Dim myRow As Long16Dim mySheet As Worksheet17 name = FileName '获取传进来的⽂件名18 myCol = col '获取传进来的结束列号19 myRow = Row '获取传进来的起始⾏号20Set mySheet = sheet '获取传进来的⼯作表指针21 endline = mySheet.Range("$A$1000000").End(xlUp).Row '如果⼯作表⾏数⼤于⼀百万，请修改这⾥的数值22 MyPath = ThisWorkbook.Path '获取本⽂件⽬录2324'创建新的⼯作簿25Set wb = Workbooks.Add26 wb.Sheets(1).Range(Cells(1, 1), Cells(endline, myCol)).NumberFormatLocal = "@"27 mySheet.Range(mySheet.Cells(myRow, 1), mySheet.Cells(endline, myCol)).Copy28 wb.Sheets(1).Range(Cells(1, 1), Cells(endline, myCol)).PasteSpecial Paste:=xlPasteValues2930 '准备输出31 MyFullName = MyPath & "\" & name & ".xlsx"'⾃动⽣成⽂件名称32 ActiveWorkbook.SaveAs FileName:=MyFullName, FileFormat:=xlWorkbookDefault, CreateBackup:=False'保存，FileFormat 为下⾯列表中的指定格式，这⾥默认为xlsx33 ActiveWorkbook.Close '关闭新⽣成的⼯作簿34End Function（2022-02-08更新）最近忙于整理数据并输出，特此将常⽤的核⼼代码分享出来，供有需要的⼈调⽤。

VB打开EXCEL的方法在Visual Basic中，可以使用多种方法打开Excel文件。

以下是其中一些常用的方法。

1. 使用Excel对象库：使用Excel对象库可以直接在VB中打开Excel文件，并获取其内容。

首先，需要在VB项目中引用Excel对象库。

打开VB项目，在树状视图中选择"项目"，然后选择"引用"。

在"可用组件"中找到"Microsoft Excel x.x Object Library"（其中 x.x 是Excel的版本号），勾选并点击"确定"。

接下来，可以使用以下代码打开Excel文件：```vbImports Excel = Microsoft.Office.Interop.ExcelDim xlApp As Excel.ApplicationDim xlWorkbook As Excel.WorkbookDim xlWorksheet As Excel.Worksheet' 创建Excel应用程序对象xlApp = New Excel.ApplicationxlApp.Visible = True' 打开Excel文件xlWorkbook =xlApp.Workbooks.Open("C:\path\to\your\excel\file.xlsx") xlWorksheet = xlWorkbook.Worksheets(1) ' 打开第一个工作表```通过以上代码，将打开Excel文件并将第一个工作表赋值给xlWorksheet 变量。

2. 使用OleDb连接：除了使用Excel对象库，还可以使用OleDb连接字符串来打开Excel 文件。

这种方法不需要引用Excel对象库，并且适用于各种版本的Excel 文件。

```vbImports System.Data.OleDbDim connectionString As String ="Provider=Microsoft.ACE.OLEDB.12.0;DataSource=C:\path\to\your\excel\file.xlsx;Extended Properties=Excel 12.0"Dim connection As OleDbConnection = NewOleDbConnection(connectionString)Dim adapter As OleDbDataAdapterDim dataSet As DataSet'打开连接connection.Open' 读取Excel数据dataSet = New DataSetadapter.Fill(dataSet)' 将数据加载到DataGridView控件DataGridView1.DataSource = dataSet.Tables(0)'关闭连接connection.Close```以上代码使用OleDb连接字符串连接到Excel文件，并将数据加载到DataSet中。

方法一：Use**.dbfCopy To Excel333.Xls Type Xl5方法二：local myfieldyfilename=getfile("**.dbf")&&得到源表myoleapp=createobject("excel.application") &&创建OLE对象myoleapp.visible=.t.myoleapp.workbooks.adduse 1.dbf &&myfilenamefor i=1 to fcount()myoleapp.cells(1,i).value=field(i)endforscanfor i=1 to fcount()myfield=fields(i)myoleapp.cells(recno()+1,i).value=&myfieldendforendscanmyoleapp.quit还有没有其他的方法！--------------------------------------------------------------------------------1、_CLIPTEXT=''SELECT bh,xm FROM h:\gzkd\jzg INTO CURSOR ddSELECT ddCOPY TO dd1.txt sdf_CLIPTEXT =FILETOSTR('dd1.txt')2、SELECT qq,bh,xmold,dwold,xfgzold,zfgzold,bfold,xm,dw,xfgz,zfgz,bf FROM r:\temp\qwe INTO CURSOR dd_vfp.DataToClip('dd',,3)ZX = CREATEOBJECT('excel.application',' ')zx.ActiveSheet.Paste--------------------------------------------------------------------------------3Set oConnection = CreateObject("adodb.connection")Set dd = CreateObject("adodb.recordset")With oConnection.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" + ThisWorkbook.FullName + ";Extended Properties='excel 8.0;HDR=YES;IMEX=1';Persist Security Info=False".OpenEnd Withdd.Open "select trim(订单号) as 订单号,count(*) as gs from [sheet1$] group by trim(订单号)", oConnection"select * from (select trim(订单号) as 订单号,count(*) as gs from [sheet1$] group by trim(订单号)) where gs=1", oConnectionSheets.AddSheets(1).Range("a1").CopyFromRecordset dd--------------------------------------------------------------------------------上述代码是VB的，略加修改即可在VFP下运行--------------------------------------------------------------------------------一般只用第1种方法（这是VFP的特长，其他开发工具没有VFP方便，都应该用方法2）--------------------------------------------------------------------------------VFP与EXCEL的几种交互编程方法一、EXECL驱动VFPEXECL内置的VBA语言（Visual Basic For Application）为EXECL功能的扩展提供了便利的手段，用户可使用该语言直接驱动VFP完成数据检索等功能。

VBA中的数据输入与输出操作技巧VBA（Visual Basic for Applications）是一种用于在Microsoft Office应用程序中编写宏的编程语言。

它有助于自动化重复性任务，提高工作效率。

在VBA中，数据的输入和输出是非常重要的操作。

本文将介绍一些在VBA中进行数据输入和输出的技巧，以帮助您更好地运用VBA编程。

1. 数据的输入在VBA中，可以通过多种方式输入数据，如键盘输入、从文件读取数据或从其他应用程序中获取数据。

以下是一些常用的数据输入技巧：1.1 键盘输入使用VBA的InputBox函数可以弹出一个对话框，让用户输入数据。

可以通过以下示例代码实现：```Dim userInput As StringuserInput = InputBox("请输入您的姓名", "用户输入")```1.2 从文件读取数据可以使用VBA的Open语句和Input函数从文件中读取数据。

下面的代码演示了如何读取一个文本文件的内容：```Dim fileName As String, fileContent As StringfileName = "C:\path\to\file.txt"Open fileName For Input As #1fileContent = Input(LOF(1), #1)Close #1```1.3 从其他应用程序获取数据VBA还支持与其他应用程序的交互，比如Excel、Word或Access等。

可以使用VBA的对象模型来获取这些应用程序中的数据。

以下是一个从Excel获取数据的示例：```Dim excelApp As Object, workbook As Object, sheet As Object Set excelApp = CreateObject("Excel.Application")Set workbook =excelApp.Workbooks.Open("C:\path\to\workbook.xlsx")Set sheet = workbook.Sheets(1)Dim data As Variantdata = sheet.Range("A1:B10").Valueworkbook.Close FalseexcelApp.Quit```2. 数据的输出在VBA中，我们不仅可以输入数据，还可以输出数据到屏幕、文本文件、Excel等。

vb用filesystemobject的savetofile方法概述说明1. 引言1.1 概述引言部分旨在介绍本篇文章的主题及内容。

该文章主要讨论VB中使用FileSystemObject的SaveToFile方法，通过对该方法进行概述和详解，我们将了解它在文件操作和数据保存方面的功能和应用场景。

1.2 文章结构本篇文章共分为五个部分，包括引言、正文、示例与应用场景、注意事项与常见问题解答以及结论。

在引言部分中，我们将简要介绍本篇文章的主题和目录结构。

1.3 目的在引言部分最后，我们需要明确表达本篇文章的目标。

通过深入地研究VB 中FileSystemObject的SaveToFile方法，我们希望读者能够全面理解该方法并掌握其正确使用方式。

同时，通过示例与应用场景的分享和注意事项与常见问题解答的总结，我们将帮助读者更好地应用这一方法，并避免在实际应用过程中可能遇到的问题。

这样撰写后“1. 引言”部分就会变成这样：1. 引言1.1 概述引言部分旨在介绍本篇文章的主题及内容。

该文章主要讨论VB中使用FileSystemObject的SaveToFile方法，通过对该方法进行概述和详解，我们将了解它在文件操作和数据保存方面的功能和应用场景。

1.2 文章结构本篇文章共分为五个部分，包括引言、正文、示例与应用场景、注意事项与常见问题解答以及结论。

在引言部分中，我们将简要介绍本篇文章的主题和目录结构。

1.3 目的在引言部分最后，我们需要明确表达本篇文章的目标。

通过深入地研究VB 中FileSystemObject的SaveToFile方法，我们希望读者能够全面理解该方法并掌握其正确使用方式。

同时，通过示例与应用场景的分享和注意事项与常见问题解答的总结，我们将帮助读者更好地应用这一方法，并避免在实际应用过程中可能遇到的问题。

2. 正文:2.1 VB语言简介:VB（Visual Basic）是一种基于事件驱动的编程语言，它在Microsoft公司开发的集成开发环境(IDE)中得到了广泛应用。

ExcelVBA编程与宏自动导出如何设定宏的自动导出和批量导出Excel VBA编程与宏自动导出Excel是一种常用的电子表格软件，而VBA（Visual Basic for Applications）是一种用于自动化任务的编程语言。

在Excel中，VBA 编程可以帮助用户实现各种功能，其中包括自动导出和批量导出，以提高工作效率。

一、VBA宏的基础概念在开始讨论如何设定宏的自动导出和批量导出之前，我们首先需要了解一些VBA宏的基础概念。

1. VBA宏是什么？VBA宏是由一系列VBA代码组成的程序，可以在Excel中执行特定的任务或操作。

2. VBA编辑器VBA编辑器是用于创建、编辑和管理VBA宏的工具。

您可以通过按下Alt + F11键来打开VBA编辑器。

3. 宏录制器宏录制器是VBA编辑器中的一个功能，允许您录制和执行特定的操作，然后将其保存为VBA宏。

二、如何设定宏的自动导出1. 打开VBA编辑器按下Alt + F11键来打开VBA编辑器。

2. 创建一个新的VBA宏在VBA编辑器中，选择“插入” -> “模块”，然后在模块中编写您的VBA代码。

您可以按照下面的示例代码编写自动导出的宏：```VBASub AutoExport()' 定义变量Dim FilePath As StringDim FileName As String' 设置保存路径和文件名称FilePath = "C:\Exports\" ' 指定导出文件保存路径FileName = "Export_" & Format(Now(), "yyyymmddhhmmss") & ".xlsx" ' 自动生成文件名' 执行导出操作ActiveSheet.SaveAs FilePath & FileNameEnd Sub```3. 设定自动触发事件为了将宏设定为自动导出，可以使用Excel的事件触发器。

Private Sub cmdSwatch_Click()Dim xls As excel.ApplicationDim xlbook As excel.Workbook'On Error GoTo exlErrorDim i As IntegerIf Dir(Text1.Text) <> "" Then '此目录下如有同名文件给出提示,并作相应处理If MsgBox("文件已存在，是否覆盖！", vbYesNo + vbQuestion, "另存为工程造价文件") = vbNo Then Exit SubElseKill (Text1.Text) '删除文件End IfEnd If'************打开工作表***************Set xls = New excel.Applicationxls.Visible = TrueSet xlbook = xls.Workbooks.Add'*********************************For i = 0 To 14If Check2(i).Value = vbChecked ThenSelect Case iCase 8ToExcelJDanJiaSum.ToExcelJDanJiaSum xlbook, xlsCase 9ToExcelADanJiaSum.ToExcelADanJiaSum xlbook, xlsCase 10ToExcelCailiao.ToExcelCailiao xlbook, xlsCase 11ToExcelTsf.ToExcelTsf xlbook, xlsCase 12ToExcelZgcl.ToExcelZgcl xlbook, xlsEnd SelectEnd IfNextFor i = 0 To 6If Check3(i).Value = vbChecked ThenSelect Case iCase 0ToExcelMan.ToExcelMan xlbook, xlsCase 1ToExcelFSD_CL.ToExcelFSD_CL xlbook, xls Case 2ToExcelHNT.ToExcelHNT xlbook, xlsCase 3ToExcelZsf.ToExcelZsf xlbook, xlsCase 4ToExcelJingChang.ToExcelJingChang xlbook, xls Case 5ToExcelJDanJia.ToExcelJDanJia xlbook, xls Case 6ToExcelADanJia.ToExcelADanJia xlbook, xls End SelectEnd IfNextxlbook.SaveAs Text1.Text '保存EXCEL文件'***************************关闭EXCEL对象*******************If Check1.Value = vbChecked Thenxlbook.Closexls.QuitEnd IfSet xlbook = NothingSet xls = NothingExit Sub'exlError:' MsgBox Err.Description, vbOKOnly + vbCritical, "警告"End SubOption ExplicitPublic Sub ToExcelZgcl(ByRef xlbook, ByRef xls) '输出总工程量Dim con As New ADODB.ConnectionDim rst_gcl As New ADODB.RecordsetDim rst_qm As New ADODB.Recordset'**************************连接数据库****************************************con.CursorLocation = adUseClientcon.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strConnection & ";Persist Security Info=False"con.Openrst_gcl.Open "zonggcl", con, adOpenKeyset, adLockOptimistic, adCmdTable '打开工程量汇总表If Not (rst_gcl.BOF And rst_gcl.EOF) Thenrst_gcl.MoveFirstEnd Ifrst_qm.Open "qianming", con, adOpenKeyset, adLockOptimistic, adCmdTable '打开签名表rst_qm.MoveFirst'****************************工作表初使化*********************************** Dim xlsheet As excel.WorksheetSet xlsheet = xlbook.Sheets.Add '添加一张工作表 = "工程量汇总"xls.ActiveSheet.PageSetup.Orientation = xlLandscape '纸张设置为横向xlsheet.Columns("a:j").Font.Size = 10xlsheet.Columns("a:j").VerticalAlignment = xlVAlignCenter '垂直居中xlsheet.Columns(1).HorizontalAlignment = xlHAlignCenter '1列水平居中对齐xlsheet.Columns(1).ColumnWidth = 8xlsheet.Columns(2).HorizontalAlignment = xlHAlignLeftxlsheet.Columns(2).ColumnWidth = 26xlsheet.Columns("c:j").HorizontalAlignment = xlHAlignRightxlsheet.Columns("c:j").ColumnWidth = 10xlsheet.Columns("c:j").NumberFormatLocal = "0.00_ " '3到10列保留两位小数'***************************写入标头************************************* xlsheet.Rows(1).RowHeight = 40xlsheet.Range(xlsheet.Cells(1, 1), xlsheet.Cells(1, 10)).MergeCells = Truexlsheet.Cells(1, 1).Value = "工程量汇总"xlsheet.Cells(1, 1).Font.Size = 14xlsheet.Cells(1, 1).Font.Bold = Truexlsheet.Rows(2).RowHeight = 18xlsheet.Rows(2).HorizontalAlignment = xlHAlignCenterxlsheet.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 Integeri = 3 'i控制行Dim j As Integer 'j控制列Dim countpage As Integercountpage = 0 '控制页Do While Not rst_gcl.EOFxlsheet.Rows(i).RowHeight = 18 '控制行高For j = 1 To 10xlsheet.Cells(i, j) = rst_gcl.Fields(j) '将工程理库中的一条记录的第一个字段写入工作表中Next'每18行为一页，如果数据超出一页时进行特殊处理If i > 18 Thenxls.ActiveWindow.SmallScroll Down:=1 '活动窗口内容向下滚动1行End IfIf i Mod 18 = 0 ThenIf countpage = 0 Thenxlsheet.Range(xlsheet.Cells(2, 1), xlsheet.Cells(i, 10)).Borders.LineStyle = xlContinuous '首页加边框Elsexlsheet.Range(xlsheet.Cells(23 + (countpage - 1) * 18, 1), xlsheet.Cells(i, 10)).Borders.LineStyle = xlContinuous '中间页加边框End Ifi = i + 2 '加一条空行'******************************在非尾页写入签名**************************************xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = Truexlsheet.Cells(i, 1).Value = Space(64) & rst_qm.Fields(0)xlsheet.Rows(i).RowHeight = 30i = i + 1 '换行xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = Truexlsheet.Cells(i, 1).Value = Space(50) & rst_qm.Fields(1)xlsheet.Rows(i).RowHeight = 15i = i + 1xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = Truexlsheet.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 Ifi = i + 1rst_gcl.MoveNextLoopxlsheet.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 = Truexlsheet.Cells(i, 1).Value = Space(64) & rst_qm.Fields(0)xlsheet.Rows(i).RowHeight = 30i = i + 1 '换行xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = Truexlsheet.Cells(i, 1).Value = Space(50) & rst_qm.Fields(1)xlsheet.Rows(i).RowHeight = 15i = i + 1xlsheet.Range(xlsheet.Cells(i, 1), xlsheet.Cells(i, 10)).MergeCells = Truexlsheet.Cells(i, 1).Value = Space(55) & rst_qm.Fields(2)xlsheet.Rows(i).RowHeight = 30'*********************************************************************************** xls.ActiveWindow.View = xlPageBreakPreview '分页预览xls.ActiveWindow.Zoom = 100If con.State = adStateOpen Thenrst_gcl.Closerst_qm.CloseSet rst_gcl = NothingSet rst_qm = Nothingcon.CloseSet con = NothingEnd IfSet xlsheet = NothingEnd SubOption ExplicitPublic Sub ToExcelTsf(ByRef xlbook, ByRef xls)Dim con As New ADODB.ConnectionDim rst_tsf As New ADODB.RecordsetDim rst_qm As New ADODB.Recordset'**********************************连接数据库************************con.CursorLocation = adUseClientcon.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strConnection & ";Persist Security Info=False"con.Openrst_tsf.Open "tdefeiyong", con, adOpenKeyset, adLockOptimistic, adCmdTableIf Not (rst_tsf.BOF And rst_tsf.EOF) Thenrst_tsf.MoveFirstEnd Ifrst_qm.Open "qianming", con, adOpenKeyset, adLockOptimistic, adCmdTablerst_qm.MoveFirst'*********************************工作表初使化**********************************Dim xlsheet As excel.WorksheetSet xlsheet = xlbook.Sheets.Add = "机械台时、组时费汇总表"xlsheet.Columns(1).ColumnWidth = 5xlsheet.Columns(2).ColumnWidth = 20xlsheet.Columns(3).ColumnWidth = 7xlsheet.Columns(4).ColumnWidth = 7xlsheet.Columns(5).ColumnWidth = 7xlsheet.Columns(6).ColumnWidth = 7xlsheet.Columns(7).ColumnWidth = 7xlsheet.Columns(8).ColumnWidth = 7xlsheet.Columns(9).ColumnWidth = 7xlsheet.Columns("A:I").Font.Size = 9xlsheet.Columns("A:I").VerticalAlignment = xlVAlignCenter '垂直居中xlsheet.Columns(1).HorizontalAlignment = xlHAlignCenter '1列水平居中对齐xlsheet.Columns(2).HorizontalAlignment = xlHAlignLeft '2列水平左对齐'******************************写入标头************************************ xlsheet.Rows(1).RowHeight = 35xlsheet.Range(xlsheet.Cells(1, 1), xlsheet.Cells(1, 9)).MergeCells = Truexlsheet.Cells(1, 1).Font.Size = 14xlsheet.Cells(1, 1).Font.Bold = Truexlsheet.Cells(1, 1).Value = "机械台时、组时费汇总表"xlsheet.Cells(2, 9).Value = "单位：元"xlsheet.Range(xlsheet.Cells(3, 1), xlsheet.Cells(5, 1)).MergeCells = Truexlsheet.Cells(3, 1).Value = "编号"xlsheet.Range(xlsheet.Cells(3, 2), xlsheet.Cells(5, 2)).MergeCells = Truexlsheet.Cells(3, 2).Value = "机械名称"xlsheet.Range(xlsheet.Cells(3, 3), xlsheet.Cells(5, 3)).MergeCells = Truexlsheet.Cells(3, 3).Value = "台时费"xlsheet.Range(xlsheet.Cells(3, 4), xlsheet.Cells(3, 9)).MergeCells = Truexlsheet.Cells(3, 4).Value = "其中"xlsheet.Range(xlsheet.Cells(3, 3), xlsheet.Cells(5, 3)).MergeCells = Truexlsheet.Cells(3, 3).Value = "台时费"xlsheet.Range(xlsheet.Cells(4, 4), xlsheet.Cells(5, 4)).MergeCells = Truexlsheet.Cells(4, 4).Value = "折旧费"xlsheet.Range(xlsheet.Cells(4, 5), xlsheet.Cells(5, 5)).MergeCells = Truexlsheet.Cells(4, 5).Value = "修理替换费"xlsheet.Range(xlsheet.Cells(4, 6), xlsheet.Cells(5, 6)).MergeCells = Truexlsheet.Cells(4, 6).Value = "安拆费"xlsheet.Range(xlsheet.Cells(4, 7), xlsheet.Cells(5, 7)).MergeCells = Truexlsheet.Cells(4, 7).Value = "人工费"xlsheet.Range(xlsheet.Cells(4, 8), xlsheet.Cells(5, 8)).MergeCells = Truexlsheet.Cells(4, 8).Value = "燃料费"xlsheet.Range(xlsheet.Cells(4, 9), xlsheet.Cells(5, 9)).MergeCells = Truexlsheet.Cells(4, 9).Value = "其他费"xlsheet.Range(xlsheet.Cells(1, 1), xlsheet.Cells(5, 9)).HorizontalAlignment = xlHAlignCenterxls.ActiveSheet.PageSetup.PrintTitleRows = "$1:$5" '固定表头'****************************************写入内容************************************* Dim i As Integeri = 6Do While Not rst_tsf.EOFxlsheet.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 Thenxls.ActiveWindow.SmallScroll Down:=1 '活动窗口内容向下滚动1行End Ifi = i + 1rst_tsf.MoveNextLoopxlsheet.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 Thenrst_tsf.Closerst_qm.CloseSet rst_tsf = NothingSet rst_qm = Nothingcon.CloseSet con = NothingEnd IfSet xlsheet = NothingEnd Sub精彩的后续作者Blog：/mi6236/。