一.函数 Private Sub ExportToExcel(sql As String, conStr As String) On Error GoTo EXPORT_ERR Dim rs As Object Dim xlApp As Object Dim xlBook As Object Dim xlSheet As Object Dim xlQuery As Object Set rs = CreateObject("Adodb.Recordset") rs.CursorLocation = adUseClient rs.Open sql, conStr If rs.RecordCount < 1 Then MsgBox ("没有记录!"), vbExclamation Exit Sub End If Dim rowCount As Integer Dim colCount As Integer rowCount = rs.RecordCount '记录总数 colCount = rs.Fields.Count '字段总数 Set xlApp = CreateObject("Excel.Application") Set xlBook = Nothing Set xlSheet = Nothing Set xlBook = xlApp.Workbooks().Add Set xlSheet = xlBook.Worksheets("sheet1") '添加查询语句,导入EXCEL数据 Set xlQuery = xlSheet.QueryTables.Add(rs,xlSheet.Range"a1")) With xlQuery .FieldNames = True .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .BackgroundQuery = True .RefreshStyle = xlInsertDeleteCells .SavePassword = True .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .PreserveColumnInfo = True End With xlQuery.Refresh xlApp.Application.Visible = True Set xlApp = Nothing '"交还控制给Excel Set xlBook = Nothing Set xlSheet = Nothing Set rs = Nothing Exit Sub EXPORT_ERR: MsgBox Err.Source & vbCrLf & vbCrLf & _ Err.Description, vbExclamation, "信息" End Sub 二.用法 Private Sub Command1_Click() Dim sql As String '查询语句 Dim conStr As String '连接字符串 sql = "select * from Customers" conStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=D:/Program Files/Microsoft Visual Studio/VB98/NWIND.MDB;Persist Security Info=False" Call ExportToExcel(sql, conStr) '调用函数 End Sub