如果你想将查询结果导出到Excel另存，以便日后查看或打印的话，那么我这里说的就是怎样将查询结果导出到Excel。先来写一个函数FillDataArray，该函数的主要作用是将查询语句中的字段名和查到的记录导入到Excel中。

Public Function FillDataArray(asArray(), adoRS As ADODB.Recordset) As Long

'将数据送 Excel 函数

Dim nRow As Integer

Dim nCol As Integer

On Error GoTo FillError

ReDim asArray(100000, adoRS.Fields.Count)

nRow = 0

For nCol = 0 To adoRS.Fields.Count - 1

asArray(nRow, nCol) = adoRS.Fields(nCol).Name

Next nCol

nRow = 1

Do While Not adoRS.EOF

For nCol = 0 To adoRS.Fields.Count - 1

asArray(nRow, nCol) = adoRS.Fields(nCol).Value

Next nCol

adoRS.MoveNext

nRow = nRow + 1

Loop

nRow = nRow + 1

FillDataArray = nRow

Exit Function

FillError:

MsgBox Error$

Exit Function

Resume

End Function

然后再来写一个过程PrintList，来调用前面的这个函数。

Private Sub PrintList()

Dim strSource, strDestination As String

Dim asTempArray()

Dim INumRows As Long

Dim objExcel As Excel.Application

Dim objRange As Excel.Range

On Error GoTo ExcelError

Set objExcel = New Excel.Application '新建一个Excel

Dim rs As New ADODB.Recordset

Set rs = Conn.Execute(sqlall)‘sqlall是查询语句

If Not rs.EOF Then

objExcel.Workbooks.Open App.Path & "\vvv.xls"

MsgBox "查询结果导出后，请将其另存为一个.xls文件，使vvv.xls中的内容为空，确保后面查询结果的正确导出。"

INumRows = FillDataArray(asTempArray, rs) '调填充数组函数

objExcel.Cells(1, 1) = "查询结果" '填表头

Set objRange = objExcel.Range(objExcel.Cells(2, 1), objExcel.Cells(INumRows, rs.Fields.Count))

objRange.Value = asTempArray '填数据

End If

objExcel.Visible = True '显示Excel

objExcel.DisplayAlerts = True '提示保存Excel

Exit Sub

ExcelError:

If Err <> 432 And Err > 0 Then

MsgBox Error$

Set objExcel = Nothing

Exit Sub

Else

Resume Next

End If

End Sub

其中用到的vvv.xls必须是先建好了的xls文件。结果导出后不要直接保存，而要将其另存为一个.xls文件，使vvv.xls中的内容为空，确保后面查询结果的正确导出。