Public Function GetR(rs As Object, n As Long) As Variant
Dim a As Variant
Dim c() As Variant
Dim i, l, k As Long

l = rs.Fields.Count

a = rs.GetRows(n) ' выгрузив 80000 и съев всю память здесь падает

ReDim c(n - 1, l - 1)

For i = 0 To n - 1
For k = 0 To l - 1
c(i, k) = a(k, i)
Next k
Next i

Erase a
Set a = Nothing

GetR = c

Erase c
'Set c = Nothing

End Function


'функция выгрузки
Public Sub ADORun(ByVal FuncOrProcNameWithParams As String, _
ByVal FuncOrProcType As Byte, _
Optional FirstRow As Long = 0, _
Optional FirstCol As Long = 0, _
Optional LastCol As Long = 0)
Dim FuncOrProcCall As String
Dim CurLastRow As Long
Dim a As Variant
Dim n As Long
Dim j As Long

Select Case FuncOrProcType
Case adProc, adProcRetCur
FuncOrProcCall = "{call " + FuncOrProcNameWithParams + "}"
Case adFunc
FuncOrProcCall = "{? = call " + FuncOrProcNameWithParams + "}"
End Select

Command.CommandText = FuncOrProcCall
Command.Prepared = True

Select Case FuncOrProcType
Case adProc

Set ADOExec = Command.Execute()

Case adProcRetCur

Set RecordSet = Command.Execute() 'у меня такая команда

Call ClearRange(FirstRow, FirstCol, LastCol)

'изначально пробовал так
'With ThisWorkbook.ActiveSheet.QueryTables.Add( _
' Connection:=RecordSet, _
' Destination:=Cells(FirstRow, FirstCol))
' .Name = "Data List"
' .FieldNames = False
' .PreserveFormatting = True
' .RefreshStyle = xlOverwriteCells
' .AdjustColumnWidth = False
' .Refresh BackgroundQuery:=True
'End With

'Cells(FirstRow, FirstCol).CopyFromRecordset RecordSet ' потом так
' последний вариант грузить по 10000 строк
If Not RecordSet.EOF Then
'RecordSet.MoveLast
RecordSet.MoveFirst
End If

n = RecordSet.Fields("RowCnt")
If n <= 10000 Then

a = GetR(RecordSet, n) 'RecordSet.RecordCount)

Range(Cells(FirstRow, FirstCol), Cells(UBound(a, 1) + FirstRow, UBound(a, 2) + FirstCol)) = a
Else

For j = 1 To n \ 10000
a = GetR(RecordSet, 10000)
Range(Cells((j - 1) * 10000 + FirstRow, FirstCol), Cells((j - 1) * 10000 + UBound(a, 1) + FirstRow, UBound(a, 2) + FirstCol)) = a
Next j
a = GetR(RecordSet, n Mod 10000)
Range(Cells(n - (n Mod 10000) + FirstRow, FirstCol), Cells(n + FirstRow, UBound(a, 2) + FirstCol)) = a

End If