Transfer data in a record from access to excel

G

Guest

I have used used VB code to transfer Data from a Query in Access 97 to Cells
in Excel 97, However as the Row increases in Excel, the speed of the data
input slows to a vertual standstill. Does anyone know a better way?
here is the code I've used. As the Value of R increases the longer and
longer it takes

Sub Excel_Keys()

Dim Xl As Object, Dbs As Database
Dim Rst As Recordset, Str As String
Dim RstA As Recordset, StrA As String

Set Dbs = CurrentDb
Set Rst = Dbs.OpenRecordset("Table", dbOpenDynaset)
Set RstA = Dbs.OpenRecordset("TableA", dbOpenDynaset)

Set Xl = GetObject("c:\Temp.xlt")
With Xl.Application
.Visible = True
.Windows("Temp.xlt").Visible = True
End With

Dim M, Col, Column, P, R, Key, PDetail, Project, ProjectNo
Dim Row As Integer

ProjectNo = Forms![TableA]![Project ID]
Project = DLookup("[Store Name]", "QryA", "[Project ID] = " & ProjectNo & "")

TopPhase = DLast("[Phase]", "Qry TopPhase", "[Project ID] = " & ProjectNo &
"")

For P = 1 To 10
Column = 1 + ((P - 1) * 16)

For R = 1 To 40
Row = 1 + ((R - 1) * 41)

PDetail = DLookup("[Profile Detail]", "Table", "[Project ID]= " & ProjectNo
& " and [Phase]= " & P & " and [ARun]= " & R & " and [Order]= 1")
StrA = "[Detail ID] = " & PDetail
RstA.FindFirst (StrA)

With Xl.Worksheets(1)
.Cells(Row, Column) = Project
.Cells(Row, Column).Font.Name = "Comic Sans MS"
.Cells(Row, Column).Font.Size = 16
.Cells(Row, Column).Font.Bold = True
.Cells(Row, Column + 7) = "Phase " & P
.Cells(Row, Column + 15).Numberformat = "@"
.Cells(Row, Column + 15) = P & " - " & R
.Cells(Row + 5, Column) = "TEXTA"
.Cells(Row + 7, Column) = "TEXTB"
.Cells(Row + 8, Column) = "TEXTC"
.Cells(Row + 9, Column) = "TEXTDâ€

'Key Detail
.Cells(Row + 11, Column) = RstA![FIELD 1]
.Cells(Row + 12, Column) = RstA![FIELD 2]
.Cells(Row + 13, Column) = RstA![FIELD 3]
.Cells(Row + 14, Column) = RstA![FIELD 4]
.Cells(Row + 15, Column) = RstA![FIELD 5]
.Cells(Row + 16, Column) = RstA![FIELD 6]
.Cells(Row + 17, Column) = RstA![FIELD 7]
.Cells(Row + 18, Column) = RstA![FIELD 8]
.Cells(Row + 19, Column) = RstA![FIELD 9]
.Cells(Row + 20, Column) = RstA![FIELD 10]
.Cells(Row + 21, Column) = RstA![FIELD 11]
.Cells(Row + 22, Column) = RstA![FIELD 12]
.Cells(Row + 23, Column) = RstA![FIELD 13]
.Cells(Row + 24, Column) = RstA![FIELD 14]
.Cells(Row + 25, Column) = RstA![FIELD 15]
.Cells(Row + 26, Column) = RstA![FIELD 16]
.Cells(Row + 27, Column) = RstA![FIELD 17]
.Cells(Row + 28, Column) = RstA![FIELD 18]
.Cells(Row + 29, Column) = RstA![FIELD 19]
.Cells(Row + 30, Column) = RstA![FIELD 20]
.Cells(Row + 31, Column) = RstA![FIELD 21]
.Cells(Row + 32, Column) = RstA![FIELD 22]
.Cells(Row + 33, Column) = RstA![FIELD 23]
.Cells(Row + 34, Column) = RstA![FIELD 24]
.Cells(Row + 35, Column) = RstA![FIELD 25]
.Cells(Row + 36, Column) = RstA![FIELD 26]
.Cells(Row + 37, Column) = RstA![FIELD 27]
.Cells(Row + 38, Column) = RstA![FIELD 28]
.Cells(Row + 39, Column) = RstA![FIELD 29]
.Cells(Row + 40, Column) = RstA![FIELD 30]

End With

For M = 1 To 13

If M = 13 Then Col = Column + M + 2 Else Col = Column + M + 1
Str = "[Project ID]= " & ProjectNo & " and [Phase]= " & P & " and [ARun]= "
& R & " and [Order]= " & M & ""
Rst.FindFirst (Str)
Key = Rst![KEY ID]
If IsNull(Key) Then GoTo Jump
If Key = "0" Then GoTo Jump

With Xl.Worksheets(1)
.Cells(Row + 2, Col) = DLookup("[FIELD A]", "Profile Loading", "[KEY ID]
= " & Key)
.Cells(Row + 3, Col) = DLookup("[FIELD B]", "Profile Loading", "[KEY ID]
= " & Key)
.Cells(Row + 5, Col) = DLookup("[FIELD C]", "Profile Loading", "[KEY
ID]=" & Key)
.Cells(Row + 7, Col) = DLookup("[FIELD D]", "Profile Loading", "[KEY
ID]= " & Key)
.Cells(Row + 8, Col) = DLookup("[FIELD E]", "Profile Loading", "[KEY
ID]= " & Key)
.Cells(Row + 9, Col) = DLookup("[FIELD F]", "Profile Loading", "[KEY
ID]= " & Key)
.Cells(Row + 11, Col) = Rst![FIELD 1]
.Cells(Row + 12, Col) = Rst![FIELD 2]
.Cells(Row + 13, Col) = Rst![FIELD 3]
.Cells(Row + 14, Col) = Rst![FIELD 4]
.Cells(Row + 15, Col) = Rst![FIELD 5]
.Cells(Row + 16, Col) = Rst![FIELD 6]
.Cells(Row + 17, Col) = Rst![FIELD 7]
.Cells(Row + 18, Col) = Rst![FIELD 8]
.Cells(Row + 19, Col) = Rst![FIELD 9]
.Cells(Row + 20, Col) = Rst![FIELD 10]
.Cells(Row + 21, Col) = Rst![FIELD 11]
.Cells(Row + 22, Col) = Rst![FIELD 12]
.Cells(Row + 23, Col) = Rst![FIELD 13]
.Cells(Row + 24, Col) = Rst![FIELD 14]
.Cells(Row + 25, Col) = Rst![FIELD 15]
.Cells(Row + 26, Col) = Rst![FIELD 16]
.Cells(Row + 27, Col) = Rst![FIELD 17]
.Cells(Row + 28, Col) = Rst![FIELD 18]
.Cells(Row + 29, Col) = Rst![FIELD 19]
.Cells(Row + 30, Col) = Rst![FIELD 20]
.Cells(Row + 31, Col) = Rst![FIELD 21]
.Cells(Row + 32, Col) = Rst![FIELD 22]
.Cells(Row + 33, Col) = Rst![FIELD 23]
.Cells(Row + 34, Col) = Rst![FIELD 24]
.Cells(Row + 35, Col) = Rst![FIELD 25]
.Cells(Row + 36, Col) = Rst![FIELD 26]
.Cells(Row + 37, Col) = Rst![FIELD 27]
.Cells(Row + 38, Col) = Rst![FIELD 28]
.Cells(Row + 39, Col) = Rst![FIELD 29]
.Cells(Row + 40, Col) = Rst![FIELD 30]
End With

Jump:
Next M
Next R
Next P

End Sub
 
J

John Nurick

A couple of general points:

1) Minimise the number of DLookups. This is a slow operation and you're
doing 30,000 of them, in batches of 6 that seem to retrieve 6 fields
from the same record. Instead, build a SQL SELECT statement that returns
all six fields from the record, use that to open a recordset, and get
the field values from that.

2) Minimise the amount of iterating through recordsets. Ideally,
i) build and execute a query (maybe a crosstab?) that returns all or
most of the data for a worksheet and turn it into an Append query that
writes directly to the worksheet using syntax like this:

INSERT INTO
[Excel 8.0;HDR=Yes;Database=C:\Folder\File.xls;].[Sheet$]
SELECT * FROM MyQuery
;

ii) then use Automation to format the sheet and add any other stuff you
need.

Alternatively, use Range.CopyFromRecordset to place a whole
recordset-full of values onto the worksheet instead of handling each
cell individually.



On Thu, 31 Mar 2005 08:37:11 -0800, "Uk Male" <Uk
I have used used VB code to transfer Data from a Query in Access 97 to Cells
in Excel 97, However as the Row increases in Excel, the speed of the data
input slows to a vertual standstill. Does anyone know a better way?
here is the code I've used. As the Value of R increases the longer and
longer it takes

Sub Excel_Keys()

Dim Xl As Object, Dbs As Database
Dim Rst As Recordset, Str As String
Dim RstA As Recordset, StrA As String

Set Dbs = CurrentDb
Set Rst = Dbs.OpenRecordset("Table", dbOpenDynaset)
Set RstA = Dbs.OpenRecordset("TableA", dbOpenDynaset)

Set Xl = GetObject("c:\Temp.xlt")
With Xl.Application
.Visible = True
.Windows("Temp.xlt").Visible = True
End With

Dim M, Col, Column, P, R, Key, PDetail, Project, ProjectNo
Dim Row As Integer

ProjectNo = Forms![TableA]![Project ID]
Project = DLookup("[Store Name]", "QryA", "[Project ID] = " & ProjectNo & "")

TopPhase = DLast("[Phase]", "Qry TopPhase", "[Project ID] = " & ProjectNo &
"")

For P = 1 To 10
Column = 1 + ((P - 1) * 16)

For R = 1 To 40
Row = 1 + ((R - 1) * 41)

PDetail = DLookup("[Profile Detail]", "Table", "[Project ID]= " & ProjectNo
& " and [Phase]= " & P & " and [ARun]= " & R & " and [Order]= 1")
StrA = "[Detail ID] = " & PDetail
RstA.FindFirst (StrA)

With Xl.Worksheets(1)
.Cells(Row, Column) = Project
.Cells(Row, Column).Font.Name = "Comic Sans MS"
.Cells(Row, Column).Font.Size = 16
.Cells(Row, Column).Font.Bold = True
.Cells(Row, Column + 7) = "Phase " & P
.Cells(Row, Column + 15).Numberformat = "@"
.Cells(Row, Column + 15) = P & " - " & R
.Cells(Row + 5, Column) = "TEXTA"
.Cells(Row + 7, Column) = "TEXTB"
.Cells(Row + 8, Column) = "TEXTC"
.Cells(Row + 9, Column) = "TEXTD”

'Key Detail
.Cells(Row + 11, Column) = RstA![FIELD 1]
.Cells(Row + 12, Column) = RstA![FIELD 2]
.Cells(Row + 13, Column) = RstA![FIELD 3]
.Cells(Row + 14, Column) = RstA![FIELD 4]
.Cells(Row + 15, Column) = RstA![FIELD 5]
.Cells(Row + 16, Column) = RstA![FIELD 6]
.Cells(Row + 17, Column) = RstA![FIELD 7]
.Cells(Row + 18, Column) = RstA![FIELD 8]
.Cells(Row + 19, Column) = RstA![FIELD 9]
.Cells(Row + 20, Column) = RstA![FIELD 10]
.Cells(Row + 21, Column) = RstA![FIELD 11]
.Cells(Row + 22, Column) = RstA![FIELD 12]
.Cells(Row + 23, Column) = RstA![FIELD 13]
.Cells(Row + 24, Column) = RstA![FIELD 14]
.Cells(Row + 25, Column) = RstA![FIELD 15]
.Cells(Row + 26, Column) = RstA![FIELD 16]
.Cells(Row + 27, Column) = RstA![FIELD 17]
.Cells(Row + 28, Column) = RstA![FIELD 18]
.Cells(Row + 29, Column) = RstA![FIELD 19]
.Cells(Row + 30, Column) = RstA![FIELD 20]
.Cells(Row + 31, Column) = RstA![FIELD 21]
.Cells(Row + 32, Column) = RstA![FIELD 22]
.Cells(Row + 33, Column) = RstA![FIELD 23]
.Cells(Row + 34, Column) = RstA![FIELD 24]
.Cells(Row + 35, Column) = RstA![FIELD 25]
.Cells(Row + 36, Column) = RstA![FIELD 26]
.Cells(Row + 37, Column) = RstA![FIELD 27]
.Cells(Row + 38, Column) = RstA![FIELD 28]
.Cells(Row + 39, Column) = RstA![FIELD 29]
.Cells(Row + 40, Column) = RstA![FIELD 30]

End With

For M = 1 To 13

If M = 13 Then Col = Column + M + 2 Else Col = Column + M + 1
Str = "[Project ID]= " & ProjectNo & " and [Phase]= " & P & " and [ARun]= "
& R & " and [Order]= " & M & ""
Rst.FindFirst (Str)
Key = Rst![KEY ID]
If IsNull(Key) Then GoTo Jump
If Key = "0" Then GoTo Jump

With Xl.Worksheets(1)
.Cells(Row + 2, Col) = DLookup("[FIELD A]", "Profile Loading", "[KEY ID]
= " & Key)
.Cells(Row + 3, Col) = DLookup("[FIELD B]", "Profile Loading", "[KEY ID]
= " & Key)
.Cells(Row + 5, Col) = DLookup("[FIELD C]", "Profile Loading", "[KEY
ID]=" & Key)
.Cells(Row + 7, Col) = DLookup("[FIELD D]", "Profile Loading", "[KEY
ID]= " & Key)
.Cells(Row + 8, Col) = DLookup("[FIELD E]", "Profile Loading", "[KEY
ID]= " & Key)
.Cells(Row + 9, Col) = DLookup("[FIELD F]", "Profile Loading", "[KEY
ID]= " & Key)
.Cells(Row + 11, Col) = Rst![FIELD 1]
.Cells(Row + 12, Col) = Rst![FIELD 2]
.Cells(Row + 13, Col) = Rst![FIELD 3]
.Cells(Row + 14, Col) = Rst![FIELD 4]
.Cells(Row + 15, Col) = Rst![FIELD 5]
.Cells(Row + 16, Col) = Rst![FIELD 6]
.Cells(Row + 17, Col) = Rst![FIELD 7]
.Cells(Row + 18, Col) = Rst![FIELD 8]
.Cells(Row + 19, Col) = Rst![FIELD 9]
.Cells(Row + 20, Col) = Rst![FIELD 10]
.Cells(Row + 21, Col) = Rst![FIELD 11]
.Cells(Row + 22, Col) = Rst![FIELD 12]
.Cells(Row + 23, Col) = Rst![FIELD 13]
.Cells(Row + 24, Col) = Rst![FIELD 14]
.Cells(Row + 25, Col) = Rst![FIELD 15]
.Cells(Row + 26, Col) = Rst![FIELD 16]
.Cells(Row + 27, Col) = Rst![FIELD 17]
.Cells(Row + 28, Col) = Rst![FIELD 18]
.Cells(Row + 29, Col) = Rst![FIELD 19]
.Cells(Row + 30, Col) = Rst![FIELD 20]
.Cells(Row + 31, Col) = Rst![FIELD 21]
.Cells(Row + 32, Col) = Rst![FIELD 22]
.Cells(Row + 33, Col) = Rst![FIELD 23]
.Cells(Row + 34, Col) = Rst![FIELD 24]
.Cells(Row + 35, Col) = Rst![FIELD 25]
.Cells(Row + 36, Col) = Rst![FIELD 26]
.Cells(Row + 37, Col) = Rst![FIELD 27]
.Cells(Row + 38, Col) = Rst![FIELD 28]
.Cells(Row + 39, Col) = Rst![FIELD 29]
.Cells(Row + 40, Col) = Rst![FIELD 30]
End With

Jump:
Next M
Next R
Next P

End Sub
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Excel How to capture data to a specified excel sheet(first workbook) of two different workbooks from the 0
Array with many cells from a row but not in order or together 11
Importing a multi-sheet Excel spreadsheet into Access 9
col A,B and C-P moved fr Sheet 1,2, to Sheet 4 4
Sub runs, but gives error when called. 7
Loop returns only one value, does not loop & an assignment to columnhow-to problem. 26
VLOOKUP Function returning multiple values in a separate table 8
add a date in a row from row above 1

Top