Option Compare Database
Option Explicit
Public Declare Function timeGetTime Lib "winmm.dll" () As Long

Private Function getColNameByNum(colNum As Long, Optional bAbsolute As Boolean = True)
'возвращает имя столбца в стиле A1 по его номеру
'проверка на 255 отсутствует.
'если bAbsolute=True то имя столбца предваряется знаком абсолютной ссылки $
Const numCh As Long =  26 &
Const charOffset As Long =  64 &

  Dim fL As Long, sL As Long
  If bAbsolute Then getColNameByNum = "$"
  
  fL = colNum \ numCh '26&
  sL = colNum Mod numCh '26&
  
  
  If fL >  0  Then
    If sL >  0  Then
      getColNameByNum = getColNameByNum & Chr(fL + charOffset) & Chr(sL + charOffset)
    Else
     If fL -  1  >  0  Then
       getColNameByNum = getColNameByNum & Chr(fL -  1  + charOffset)
     End If
     getColNameByNum = getColNameByNum & "Z"
    End If
  Else
    getColNameByNum = getColNameByNum & Chr(sL + charOffset)
  End If
  
End Function

Sub sub2()
  Dim arr( 100 ,  100 ) As Integer
Dim i As Integer
Dim y As Integer
For i =  1  To  100 
 For y =  1  To  100 
    arr(i -  1 , y -  1 ) =  1 
 Next y
Next i
'=============================
Dim rst As ADODB.Recordset
Set rst = New ADODB.Recordset
For i =  1  To  100 
    rst.Fields.Append "f" & i, adInteger
Next i
rst.Open
For i =  1  To  100 
 rst.AddNew
 For y =  1  To  100 
  rst.Fields("f" & y) =  1 
 Next y
Next i
'===================================
Dim App As Excel.Application
Dim Wkb As Excel.Workbook
Dim sht As Excel.Worksheet
Dim dttime As Long
Set App = CreateObject("Excel.Application")
Set Wkb = App.Workbooks.Add
Set sht = Wkb.sheets( 1 )
'теперь 2 варианта выкладки на лист
'=================================================
dttime = timeGetTime
sht.range("A1").CopyFromRecordset rst
Debug.Print timeGetTime - dttime  'показал 64 - 65
'==================================
Dim strAdr As String

dttime = timeGetTime
With sht
  strAdr = "$A$1:" & getColNameByNum( 100 ) & "$1"
  .range(strAdr).value2 = arr
'For i = 1 To 100
'For y = 1 To 100
'.Cells(i, y) = arr(i - 1, y - 1)
'Next
'Next
End With
Debug.Print timeGetTime - dttime 'показывает 4-3
'Debug.Print Second(Now() - dttime) 'показал   12


App.Visible = True

End Sub

  strAdr = "$A$1:" & getColNameByNum( 100 ) & "$101"
  .range(strAdr).value2 = arr

Sub sub3()

'===================================
Dim App As Excel.Application
Dim Wkb As Excel.Workbook
Dim sht As Excel.Worksheet, sht2 As Excel.Worksheet
Dim dttime As Long
Set App = CreateObject("Excel.Application")
Set Wkb = App.Workbooks.Add
Set sht = Wkb.sheets( 1 ) 'лист для рекордсета
Set sht2 = Wkb.sheets( 2 ) ' лист для массива
'массив со всеми накладными расходами

dttime = timeGetTime

ReDim arr( 100 ,  100 ) As Integer
Dim i As Integer
Dim y As Integer
For i =  1  To  100 
 For y =  1  To  100 
    arr(i -  1 , y -  1 ) = i *  100  + y
 Next y
Next i

Dim strAdr As String
strAdr = "$A$1:$CV100"

sht2.range(strAdr).value2 = arr

Debug.Print timeGetTime - dttime



'=============================
'рекордсет со всеми накладными расходами
dttime = timeGetTime

Dim rst As ADODB.Recordset
Dim tF As ADODB.Fields

Set rst = New ADODB.Recordset

For i =  1  To  100 
  
    rst.Fields.Append "f" & i, adInteger
Next i
rst.Open

Set tF = rst.Fields

For i =  1  To  100 
 rst.AddNew
 For y =  1  To  100 
   tF(y -  1 ).Value =  100  * i + y
 Next y
Next i


sht.range("A1").CopyFromRecordset rst
Debug.Print timeGetTime - dttime  'показал 0
'==================================

App.Visible = True

End Sub

Sub TestRecordSet2()
Dim rst As ADODB.Recordset
Set rst = New ADODB.Recordset

'получилось при заказе такого типа блокировки
rst.LockType = adLockBatchOptimistic

Dim i As Long, y As Long

For i =  1  To  100 
    rst.Fields.Append "f" & i, adInteger
Next i
rst.Open
For i =  1  To  100 
 rst.AddNew
 For y =  1  To  100 
  rst.Fields("f" & y) = i *  1000  + y
 Next y
Next i

rst.Filter = adFilterPendingRecords
rst.Delete adAffectGroup
'тут показывает неясно что - фантом
Debug.Print rst.RecordCount, rst.AbsolutePosition
'снимаем  фильтр
rst.Filter = vbNullString
'проверяем, что получилось...
Debug.Print rst.RecordCount, rst.AbsolutePosition
rst.Close
End Sub

rst.Filter = adFilterNone

rst.CancelBatch
rst.MoveFirst