Export data to excel

[ayazgreat]

Hi

I have received following macro from some one but it does not work when i run my macro to export data to excel because I have 4 or five lacks records in data table when exporting in excel it gives error message and copy incomplete records could you please help to resolve it?




Public Function RecordsetToExcelMod(ByRef ERST As Recordset, _
Optional ByVal SpreadsheetName As String = "Sheet", _
Optional ByVal lMaxRows As Long = 65535)
'Use this to generate an Excel application from an ADO recordset.

Dim xlApp As Excel.Application
Dim xlWb As Excel.Workbook
Dim xlws As Excel.Worksheet
Dim rstTemp As ADODB.Recordset
Dim rstField As ADODB.Field

Dim iCol As Integer
Dim lRow As Long
Dim iTotSheets As Integer
Dim iShe As Integer

Set xlApp = New Excel.Application
Set xlWb = xlApp.Workbooks.Add
Set rstTemp = New ADODB.Recordset

If lMaxRows > 65535 Then
lMaxRows = 65535
End If

' Copy fields to the temporary recordset
For Each rstField In ERST.Fields
rstTemp.Fields.Append rstField.Name, rstField.Type, rstField.DefinedSize, rstField.Attributes And adFldIsNullable
rstTemp(rstField.Name).Precision = rstField.Precision
rstTemp(rstField.Name).NumericScale = rstField.NumericScale
Next
rstTemp.Open

ERST.MoveFirst

' Calculate how many sheets will be needed
iTotSheets = (ERST.RecordCount / lMaxRows) + 0.5

For iShe = 1 To iTotSheets
' Create additional sheets if necesary
If iShe > 3 Then
' Creates a new sheet after the previous one
xlWb.Worksheets.Add , xlWb.Worksheets(iShe - 1)
End If
Set xlws = xlWb.Worksheets(iShe)
xlws.Activate
xlws.Name = Left(SpreadsheetName & " " & iShe & " of " & iTotSheets, 31)

' Create column names in the spreadsheet
For iCol = 1 To ERST.Fields.count
xlws.Cells(1, iCol).Value = ERST.Fields(iCol - 1).Name
Next
xlApp.Selection.CurrentRegion.Font.Bold = True

' Copy records to temporary recordset.
' Only copy the maximum allowed per sheet
For lRow = 1 To lMaxRows
If ERST.EOF Then
Exit For
Else
rstTemp.AddNew
For iCol = 0 To (ERST.Fields.count - 1)
rstTemp.Fields(iCol).Value = ERST.Fields(iCol).Value
Next
rstTemp.Update
rstTemp.MoveNext
ERST.MoveNext
End If
Next
' CopyFromRecordset is faster then copying row by row to the spreadsheet.
' This is why we use a temporary recordset.
xlws.Cells(2, 1).CopyFromRecordset rstTemp
If rstTemp.RecordCount > 0 Then
rstTemp.MoveFirst
End If
' Empty temporary recordset.
Do While Not rstTemp.EOF
If Not rstTemp.EOF Then
rstTemp.Delete
End If
rstTemp.MoveNext
Loop
rstTemp.UpdateBatch
' Format spreadsheet
xlApp.Selection.CurrentRegion.Columns.AutoFit
xlApp.Selection.CurrentRegion.Rows.AutoFit

Next

xlApp.Visible = True
xlApp.UserControl = True

Set xlws = Nothing
Set xlWb = Nothing
Set xlApp = Nothing
Set rstTemp = Nothing

End Function

[CreganTur]

There's a related thread here:
http://www.vbaexpress.com/forum/showthread.php?t=18539

Here's a quote from one of the posts dealing with a basic function to create a new Spreadsheet based on a table or query:

__________






'Export data to Excel DoCmd.TransferSpreadsheet acExport,acSpreadsheetTypeExcel9,_ "TableOrQueryName", "FilepathWhereYouWantSpreadsheetSaved",True
The acSpreadsheetTypeExcel9 parameter declares which version of Excel you're running.

The True parameter at the end of the function is for whether or not the data you're exporting contains field names (column headings).

Now, this only writes new Excel spreadsheets- I'm still working on how to make them display after they've been written.

Also, after the Field Names parameter, there is space for a Range parameter- you might be able to use it to add new data to an existing spreadsheet, but that'll require some testing as I'm unsure of this.

NinjaEdit: When you set the Filepath, it must be valid. You cannot set the Filepath to something that does not exist yet.

For Example: lets say you want everything to go into the "Reports" folder at C:\Reports. This folder must exist; Access will not create the folder for you (using this Function)

[ayazgreat]

Sir

What you think about my above given code how does it work i have tried it with your given codes but it did not work

[Trevor]

it's unclear to me what you realy want to export to excel. if you want you can simply create a report then save the report as an excel worksheet.
by right clicking the resulting report and selectin Export, in the file type select excel 2003 (or whatever ver of excl your using for the year)
don't know if this helps but I decided to through it out there

[Carl A]

Hi

I have received following macro from some one but it does not work when i run my macro to export data to excel because I have 4 or five lacks records in data table when exporting in excel it gives error message and copy incomplete records could you please help to resolve it?

I'm not sure what ("I have 4 or five lacks records in data table") means.

Here is a modified version that works:

Sub main()
'Retrieve recordset to pass to function
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Set cn = CurrentProject.AccessConnection
Set rs = New ADODB.Recordset
With rs
Set .ActiveConnection = cn
.Source = "SELECT * FROM YourTable"
.LockType = adLockOptimistic
.CursorType = adOpenKeyset
.Open
End With

Call RecordsetToExcelMod(rs)

Set rs = Nothing
Set cn = Nothing
End Sub
Public Function RecordsetToExcelMod(ERST As ADODB.Recordset, _
Optional ByVal SpreadsheetName As String = "Sheet", _
Optional ByVal lMaxRows As Long = 65535)
'Use this to generate an Excel application from an ADO recordset.

Dim xlApp As Excel.Application
Dim xlWb As Excel.Workbook
Dim xlws As Excel.Worksheet
Dim rstTemp As ADODB.Recordset
Dim rstField As ADODB.Field

Dim iCol As Integer
Dim lRow As Long
Dim iTotSheets As Integer
Dim iShe As Integer

Set xlApp = New Excel.Application
Set xlWb = xlApp.Workbooks.Add
Set rstTemp = New ADODB.Recordset

If lMaxRows > 65535 Then
lMaxRows = 65535
End If

' Copy fields to the temporary recordset
For Each rstField In ERST.Fields
rstTemp.Fields.Append rstField.Name, rstField.Type, rstField.DefinedSize, rstField.Attributes And adFldIsNullable
rstTemp(rstField.Name).Precision = rstField.Precision
rstTemp(rstField.Name).NumericScale = rstField.NumericScale
Next
rstTemp.Open

ERST.MoveLast
ERST.MoveFirst

' Calculate how many sheets will be needed
iTotSheets = (ERST.RecordCount / lMaxRows) + 0.5

For iShe = 1 To iTotSheets
' Create additional sheets if necesary
If iShe > 3 Then
' Creates a new sheet after the previous one
xlWb.Worksheets.Add , xlWb.Worksheets(iShe - 1)
End If
Set xlws = xlWb.Worksheets(iShe)
xlws.Activate
xlws.Name = Left(SpreadsheetName & " " & iShe & " of " & iTotSheets, 31)

' Create column names in the spreadsheet
For iCol = 1 To ERST.Fields.Count
xlws.Cells(1, iCol).Value = ERST.Fields(iCol - 1).Name
Next
xlApp.Selection.CurrentRegion.Font.Bold = True

' Copy records to temporary recordset.
' Only copy the maximum allowed per sheet
For lRow = 1 To lMaxRows
If ERST.EOF Then
Exit For
Else
rstTemp.AddNew
For iCol = 0 To (ERST.Fields.Count - 1)
rstTemp.Fields(iCol).Value = ERST.Fields(iCol).Value
Next
rstTemp.Update
rstTemp.MoveNext
ERST.MoveNext
End If
Next
' CopyFromRecordset is faster then copying row by row to the spreadsheet.
' This is why we use a temporary recordset.
xlws.Cells(2, 1).CopyFromRecordset rstTemp
If rstTemp.RecordCount > 0 Then
rstTemp.MoveFirst
End If
' Empty temporary recordset.
Do While Not rstTemp.EOF
If Not rstTemp.EOF Then
rstTemp.Delete
End If
rstTemp.MoveNext
Loop
rstTemp.UpdateBatch
' Format spreadsheet
xlApp.Selection.CurrentRegion.Columns.AutoFit
xlApp.Selection.CurrentRegion.Rows.AutoFit

Next

xlApp.Visible = True
xlApp.UserControl = True

Set xlws = Nothing
Set xlWb = Nothing
Set xlApp = Nothing
Set rstTemp = Nothing

End Function



HTH:

[Ashfaque]

Carl,

4-5 lacs means 4-5 hundred thousands (400,000 - 500,000)

Ashfaque