'===================================== '创建 excel 并保存到指定路径 'FilePath: excel保存路径 'SheetName: 表名称 '===================================== public Sub CreateExcelFile(FilePath , SheetName) Set objExcel = CreateObject("Excel.Application")'创建 Excel 对象 objExcel.Visible = True '显示 Excel 对象 set xlsBook = objExcel.Workbooks.Add() '创建 excel 工作簿 Set objSheet = xlsBook.Worksheets("Sheet1") '获得 sheet1 表 objSheet.Name = SheetName '将表明改成 testing xlsBook.Application.DisplayAlerts = True '如果文件存在，默认处理方式为替换保存 xlsBook.SaveAs(FilePath) '保存至指定路径的 excel c:/test.xls xlsBook.Close '关闭 Set xlsBook = Nothing '释放内存 objExcel.Quit '退出 Set objExcel = Nothing '释放内存 End Sub'从数据库到处数据到 excel Dim FileName Dim i i = 0 FileName = "c:/test.xlsx" Set fso = CreateObject("Scripting.FileSystemObject") REM 判断文件是否存在 If fso.FileExists(FileName) Then Set objExcel = CreateObject("Excel.Application") Set objBook = objExcel.Workbooks.Open(FileName) Set objSheet = objBook.Sheets(1) objSheet.Name = "testing" objSheet.Activate Else Set objExcel = CreateObject("Excel.Application") '创建 excel 对象 Set objBook = objExcel.Workbooks.Add() '创建 excel 工作簿 Set objSheet = objBook.Sheets("Sheet1") '获得 Sheet1 表 objSheet.Name = "testing" '设置表明 objBook.Worksheets("Sheet2").Delete '删除 Sheet2 表 objBook.Worksheets("Sheet3").Delete '删除 Sheet3 表 objSheet.Activate '激活当前工作表 objBook.SaveAs(FileName) '文件另存为 End If objSheet.cells(1,1).value = "Order_Number" '设置列标题 objSheet.cells(1,2).value = "Customer_Name" objSheet.cells(1,3).value = "Departure_Date" objSheet.cells(1,4).value = "Flight_Number" objSheet.cells(1,5).value = "Tickets_Ordered" objSheet.cells(1,6).value = "Class" objSheet.cells(1,7).value = "Agents_Name" objSheet.cells(1,8).value = "Send_Signature_With_Order" Set conn = CreateObject("ADODB.Connection") Set rs = CreateObject("ADODB.RecordSet") REM 无需设置数据源连接方式 Const strConn = "DRIVER={Microsoft Access Driver (*.mdb)};DBQ=C:/flight32.mdb" conn.Open(strConn) '打开数据库连接 sql = "select * from Orders" '查询语句 rs.Open sql , strConn ,1,1 If rs.EOF and rs.BOF Then MsgBox "数据库中无数据" Else Do until rs.EOF Order_Number = rs("Order_Number").value Customer_Name = rs("Customer_Name").value Departure_Date = rs("Departure_Date").value Flight_Number = rs("Flight_Number").value Tickets_Ordered = rs("Tickets_Ordered").value ClassType = rs("Class").value Agents_Name = rs("Agents_Name").value Send_Signature_With_Order = rs("Send_Signature_With_Order").value objSheet.cells(i+2,1).value = Order_Number objSheet.cells(i+2,2).value = Customer_Name objSheet.cells(i+2,3).value = Departure_Date objSheet.cells(i+2,4).value = Flight_Number objSheet.cells(i+2,5).value = Tickets_Ordered objSheet.cells(i+2,6).value = ClassType objSheet.cells(i+2,7).value = Agents_Name objSheet.cells(i+2,8).value = Send_Signature_With_Order i = i + 1 rs.MoveNext Loop End If rs.Close Set rs = Nothing 'ON ERROR RESUME NEXT conn.Close '关闭时报错误？对象关闭时,不允许操作 Set conn = Nothing Set fos = Nothing objBook.Save objExcel.Visible = True Set objBook = Nothing objExcel.Quit Set objExcel = Nothing
