Это должно работать. Вы можете изменить вертикальный (maxChunk) или горизонтальный (maxCol) размеры.
Option Explicit
Sub doit()
Dim rs As adodb.Recordset
Set rs = New adodb.Recordset
rs.Open "Select * From activity1 Order By Field1", CurrentProject.Connection, _
adOpenKeyset, adLockOptimistic
rs.MoveLast
rs.MoveFirst
' Inhale ALL of the records into an array (base zero)
Dim varRecords As Variant, maxRecCnt As Long
varRecords = rs.GetRows(rs.RecordCount, , "Field1") '(rs.RecordCount)
maxRecCnt = UBound(varRecords, 2)
Debug.Print maxRecCnt
Dim x As Long
' expected output
' A B C D E F G H
' 1 6 11 16 21 26 31 36
' 2 7 12 17 22 27 32 37
' 3 8 13 18 23 28 33 38
' 4 9 14 19 24 29 34 39
' 5 10 15 20 25 30 35 40
'41
Dim allText As String
Dim maxChunk As Long, rowInChunk As Long, numChunk As Long
maxChunk = 5
rowInChunk = 0
Dim maxCol As Long, numCol As Long
maxCol = 8
numCol = 0
For numChunk = 1 To maxRecCnt / maxChunk * maxCol
For rowInChunk = 1 To maxChunk
Dim rowText As String
rowText = ""
For numCol = 1 To maxCol
' compute which cell in the array we want
x = ((numCol - 1) * maxChunk) + rowInChunk - 1 + ((numChunk - 1) * maxChunk * maxCol)
On Error Resume Next ' widows at the end
rowText = rowText & vbTab & varRecords(0, x)
Next numCol
'MsgBox (rowText)
allText = allText & vbCrLf & rowText
Next rowInChunk
allText = allText & vbCrLf
Next numChunk
MsgBox (allText)
End Sub