转置小技巧——浅谈GetRows的使用 - Office中国论坛/Access中国论坛

'函数说明：
'作用：..........................................导出数据，或转置导出数据
'引用库：........................................Excel库、ADO库。
'附件：..........................................根目录下需包含文件ExportData空白工作表，用于存储数据
'参数：
' strSQL....................................必选，SQL查询语句
' isTranspose...............................可选，是否转置，默认为不转置。
'调用方法：
'Call ExportData("第三季度套餐",True)............转置导出表“第三季度套餐”的数据。
'其它：
'由于使用了Excel组件，因此导出数据时比普通的DoCmd.TransferSpreadsheet运行要慢，建议需要转置时再使用本函数。
Function ExportData(ByVal strSQL As String, Optional ByVal isTranspose As Boolean = False)
Dim rst As New ADODB.Recordset
Dim exl As New Excel.Application
Dim wb As Workbook
Dim wsh As Worksheet
'定以数组，arrFields用于存放表头，arrData用于转置数据
Dim arrFields, arrData
Dim i As Long
rst.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
'打开工作簿
Set wb = exl.Workbooks.Open(CurrentProject.Path & "\ExportData.xls")
Set wsh = wb.ActiveSheet
'清除旧数据
wsh.Cells.ClearContents
'重定以数组维度，以便存放表头独居
ReDim arrFields(rst.Fields.Count - 1)
For i = 0 To rst.Fields.Count - 1
arrFields(i) = rst.Fields(i).Name
Next
If isTranspose Then
arrData = rst.GetRows()
'处理表头：
'Resize用于扩展区域。需要注意的是，单元格作为数组来存储数据，是从1开始的，因此后面所有的单元格都要resize到Ubound+1
wsh.Range("A1").Resize(UBound(arrFields) + 1) = exl.WorksheetFunction.Transpose(arrFields)
wsh.Range("B1").Resize(UBound(arrData, 1) + 1, UBound(arrData, 2) + 1) = arrData
Else
wsh.Range("A1").Resize(, UBound(arrFields) + 1) = arrFields
wsh.Range("A2").CopyFromRecordset rst
End If
'保存并退出Excel
wb.Save
wb.Close
exl.Quit
'关闭记录集
rst.Close
End Function

复制代码