من قبلا از این دستور برای انتقال اطلاعات به اکسل استفاده می کردم . چک کنید شاید بکارت اومد.
On Error Resume Next
Set CN = New ADODB.Connection ''''''ÏÓÊæÑ ÐÎíÑå ÏÑ Ç˜Ó
CN.Provider = "Microsoft.Jet.OLEDB.4.0"
CN.ConnectionString = App.Path & "\Dbase.mdb"
CN.Open
''''''''''''''''''''''
Dim i, J, rtot, m
Dim ctot(1 To 4)
'rtot = 0
Dim objExcl As Excel.Application
Set objExcl = New Excel.Application
objExcl.Visible = True
objExcl.SheetsInNewWorkbook = 1
objExcl.Workbooks.Add
objExcl.ActiveSheet.Cells(1, 3).Value = "ÊÇÑíÎ ß"
objExcl.ActiveSheet.Cells(1, 4).Value = "ÔãÇÑå ß"
objExcl.ActiveSheet.Cells(1, 5).Value = "äÇã ÈÇäß"
objExcl.ActiveSheet.Cells(1, 6).Value = "ãÈáÛ ß"
objExcl.ActiveSheet.Cells(1, 7).Value = "ÔÑÍ ß"
objExcl.ActiveSheet.Cells(1, 8).Value = "äæÚ ß"
objExcl.ActiveSheet.Cells(1, 9).Value = "æÖÚíÊ ß"
objExcl.ActiveSheet.Cells(1, 10).Value = "ÊæÖíÍÇÊ"
Set rs = New ADODB.Recordset
rs.Open "select * from T1 ORDER BY Tch", CN, adOpenKeyset
J = 3
Do Until rs.EOF
For i = 2 To rs.Fields.Count - 1
objExcl.ActiveSheet.Cells(J, i + 1).Value = rs.Fields(i)
If i > 2 Then
tot = crtot + rs.Fields(i)
End If
Next
objExcl.ActiveSheet.Cells(J, i + 1).Value = rtot
rs.MoveNext
J = J + 1
Loop
Dim k
k = 1
rs.MoveFirst
Do Until rs.EOF
For k = 1 To 4
ctot(k) = ctot(k) + rs.Fields(k + 2)
Next
rs.MoveNext
Loop