Я вот так выкидываю рекордсеты в Excel

' Import of recordset to Excel
' Параметры RecSource-Recordset который выкидываем в Excel
' MeForm - форма относительно которой модально я отображаю индикатор выполнения (не обязалельный параметр)
' CloumsFormat- номер последней текстовой колонки, после неё я начинаю форматировать столбцы как число ,
' если не надо форматировать вообще то передаёш число равное количеству колонок (не обязалельный параметр)
' strArrayCloumsName-если тебе надо называт колонки не так как названы поля в рекордсете, то передаёшь строковый массив названий колонок (не обязалельный параметр)
' strSheetName -имя создаваемого листа в Excel (не обязалельный параметр)
' recMyRecordset - масив Recordset ( можно в конце перврго рекордсета дописать данные ещё из других рекордсетов )
' bulSUM- флаг надо-ли в конце таблицы подсчитывать сумму

Public Sub ImportVExcel(RecSource As Recordset, Optional MeForm As Form = Empty, Optional CloumsFormat As Integer, Optional strArrayCloumsName As Variant = Empty, Optional strSheetName As String = "", Optional recMyRecordset As Variant = Empty, Optional bulSUM As Boolean = False)
On Error GoTo ErrHandler
Dim i As Integer
Dim e As Integer
Dim z As Integer
Dim Zagolovki(100) As String
Dim strSheet As String
Dim m As Integer
Dim NumFields As Integer
Dim rec As New Recordset
Dim recDataClone As Recordset

Set recDataClone = RecSource.Clone

If recDataClone.BOF And recDataClone.EOF Then
MsgBox "No Data!!"
Exit Sub
End If

If IsEmpty(strArrayCloumsName) Then
For m = 0 To recDataClone.Fields.Count - 1
Zagolovki(m) = recDataClone.Fields(m).Name
Next m
Else
For m = 0 To UBound(strArrayCloumsName)
Zagolovki(m) = strArrayCloumsName(m)
Next m
End If

Dim xlFail As Object
Set xlFail = CreateObject("Excel.Application")
xlFail.Workbooks.Add

strSheet = Replace(strSheetName, " ", "")
strSheet = Replace(strSheet, "]", "")
strSheet = Replace(strSheet, "[", "")
strSheet = Replace(strSheet, "/", "")
strSheet = Replace(strSheet, "\", "")
strSheet = Replace(strSheet, "*", "")
strSheet = Replace(strSheet, "?", "")
strSheet = Left(strSheet, 31)
With xlFail.ActiveSheet
If Not strSheetName = "" Then .Name = strSheet
For i = 1 To recDataClone.Fields.Count
.Cells(1, i).Value = Zagolovki(i - 1)
.Cells(1, i).Font.Bold = True
.Cells(1, i).BorderAround ColorIndex:=1, Weight:=3
.Cells(1, i).HorizontalAlignment = 3
.Cells(1, i).Interior.Color = RGB(32, 255, 100)
recDataClone.MoveFirst
NumFields = recDataClone.RecordCount + 1
For m = 2 To NumFields
.Cells(m, i).Value = recDataClone.Fields(i - 1).Value
.Cells(m, i).BorderAround ColorIndex:=1, Weight:=2
'If i > CloumsFormat Then .Cells(m, i).NumberFormat = "#,##0.00_ ;[Red]-#,##0.00 " '"#,##0_ ;[Red]-#,##0 "
recDataClone.MoveNext
Next m
If Not IsEmpty(recMyRecordset) Then
For e = 0 To UBound(recMyRecordset)
Set rec = recMyRecordset(e)
rec.MoveFirst
If Not rec.BOF And Not rec.EOF Then
For m = NumFields + 1 To rec.RecordCount + NumFields
.Cells(m, i).Value = Nz(rec.Fields(i - 1).Value)
.Cells(m, i).BorderAround ColorIndex:=1, Weight:=2
.Cells(m, i).Interior.Color = RGB(230 - (20 * m), 210, 225)
'If i > CloumsFormat Then .Cells(m, i).NumberFormat = "#,##0.00_ ;[Red]-#,##0.00 "
rec.MoveNext
Next m
NumFields = NumFields + rec.RecordCount
End If
Next e
End If
If bulSUM Then
NumFields = NumFields + 1
Select Case i
Case 1
.Cells(NumFields, i).Value = "SUM"
Case Is > CloumsFormat
.Cells(NumFields, i).FormulaR1C1 = "=SUM(R[-" & NumFields - 2 & "]C:R[-1]C)"
'.Cells(NumFields + 1, i).NumberFormat = "#,##0.00_ ;[Red]-#,##0.00 "
Case Else
End Select
.Cells(NumFields, i).BorderAround ColorIndex:=1, Weight:=2
.Cells(NumFields, i).Interior.Color = RGB(225, 210, 225)
End If
If i > CloumsFormat Then .Columns(i).NumberFormat = "#,##0.00_ ;[Red]-#,##0.00 "
.Columns(i).AutoFit
'If Not IsEmpty(MeForm) Then frmProces.Label1.Caption = MyStr1(118) & CInt((100 / recDataClone.Fields.Count) * i) & " %"
DoEvents
Next i
End With

xlFail.Visible = True
Set xlFail = Nothing
Exit Sub
ErrHandler:
xlFail.Close False
Set xlFail = Nothing

MsgBox err.Description
End Sub

Ну можно и так

Dim q As Variant

recDataClone.MoveFirst

q = recDataClone.GetRows
q = TransposeDim(q)
xlFail.ActiveSheet.Cells(1, 1).Resize _
(recDataClone.RecordCount,recDataClone.Fields.Count).Value = q
xlFail.Visible = True
Exit Sub


Function TransposeDim(v As Variant) As Variant
' Custom Function to Transpose a 0-based array (v)

Dim X As Long, Y As Long, Xupper As Long, Yupper As Long
Dim tempArray As Variant

Xupper = UBound(v, 2)
Yupper = UBound(v, 1)

ReDim tempArray(Xupper, Yupper)
For X = 0 To Xupper
For Y = 0 To Yupper
tempArray(X, Y) = v(Y, X)
Next Y
Next X

TransposeDim = tempArray

End Function