kodu aşağıdaki gibi düzenleyip dener misiniz?
Dim Sql As String
Dim ADO_RS As ADODB.Recordset
Dim ADO_CN As ADODB.Connection
SQL = "SELECT * FROM Sorgu1"
Set ADO_RS = New ADODB.Recordset
Set ADO_CN = New ADODB.Connection
ADO_CN.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ThisWorkbook.Path & "\Örnek.accdb;"
ADO_CN.Open
ADO_RS.Open SQL, ADO_CN, 3, 1 ' güncelleme yapabilmek için 1,3 0lmalı yada adOpenKeyset, adLockOptimistic
strSy = ADO_RS.RecordCount
'hy________________________________________________
'1. sutunu A4 diyicem A4'den başlayıp aşağı doğru sıralıycak
ADO_RS.MoveFirst
Dim arr, SonDizi
Dim Itm As Variant
arr = ADO_RS.GetRows(, , 0) '<==burada 0 yazan yer 1. alan
ReDim SonDizi(LBound(arr, 2) To UBound(arr, 2), LBound(arr, 1) To UBound(arr, 1))
For i = LBound(arr, 2) To UBound(arr, 2)
For j = LBound(arr, 1) To UBound(arr, 1)
SonDizi(i, j) = arr(j, i)
Next j
Next i
'ListBox1.List = SonDizi
Sheets("Sayfa1").Range("A4").Resize(strSy) = SonDizi
'hy________________________________________________
'2. sutunu B4 diyicem B4'den başlayıp aşağı doğru sıralıycak
ADO_RS.MoveFirst
arr = ADO_RS.GetRows(, , 1) '<==burada 1 yazan yer 2. alan
ReDim SonDizi(LBound(arr, 2) To UBound(arr, 2), LBound(arr, 1) To UBound(arr, 1))
For i = LBound(arr, 2) To UBound(arr, 2)
For j = LBound(arr, 1) To UBound(arr, 1)
SonDizi(i, j) = arr(j, i)
Next j
Next i
Sheets("Sayfa1").Range("B4").Resize(strSy) = SonDizi
'hy________________________________________________
'3. sütunu D5 diyicem, onuda D5'den aşağı doğru sıralıyacak
ADO_RS.MoveFirst
arr = ADO_RS.GetRows(, , 2) '<==burada 2 yazan yer 3. alan
ReDim SonDizi(LBound(arr, 2) To UBound(arr, 2), LBound(arr, 1) To UBound(arr, 1))
For i = LBound(arr, 2) To UBound(arr, 2)
For j = LBound(arr, 1) To UBound(arr, 1)
SonDizi(i, j) = arr(j, i)
Next j
Next i
Sheets("Sayfa1").Range("D5").Resize(strSy) = SonDizi '3. Alan D5
son:
ADO_RS.Close
ADO_CN.Close
Set ADO_RS = Nothing
Set ADO_CN = Nothing