| Member | | Join Date: Aug 2006
Posts: 63
| |
I have the following code to populate an excel spreadsheet from vb6 and access database. It works great except that when it reads from the recordset and populates the spreadsheet, I would like it to populate every other line in the spreadsheet. I can't seem to see anywhere in the code where that might be handled. Any help would be greatly appreciated. - Private Sub lblGroundScheduleExcel_Click()
-
Dim cnt As New ADODB.Connection
-
Dim rst As New ADODB.Recordset
-
-
Dim xlApp As Object
-
Dim xlWb As Object
-
Dim xlWs As Object
-
-
-
Dim recArray As Variant
-
-
Dim strDB As String
-
Dim fldCount As Integer
-
Dim recCount As Long
-
Dim iCol As Integer
-
Dim iRow As Integer
-
-
' Set the string to the path of your Northwind database
-
strDB = "c:\scheduling\AAGTC_Scheduling.mdb"
-
-
' Open connection to the database
-
cnt.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
-
"Data Source=" & strDB & ";"
-
-
' Open recordset based on Orders table
-
rst.Open "Select Date, Unit, P_O_C, Mission, Vehicle_Qty, Personnel_Daily_Report, [Range Areas], Facility_Useage_For_Daily_Report, Daily_Ordinance, Comments From qryDailyGroundScheduleReport", cnt
-
-
' Create an instance of Excel and add a workbook
-
Set xlApp = CreateObject("Excel.Application")
-
Set xlWb = xlApp.Workbooks.Add("C:\Scheduling\Excel\Deployment_Activity1.xls")
-
Set xlWs = xlWb.Worksheets("2007")
-
-
' Display Excel and give user control of Excel's lifetime
-
xlApp.Visible = True
-
xlApp.UserControl = True
-
-
' Copy field names to the first row of the worksheet
-
' fldCount = rst.Fields.Count
-
' For iCol = 1 To fldCount
-
' xlWs.Cells(1, iCol).Value = rst.Fields(iCol - 1).Name
-
'Next
-
-
' Check version of Excel
-
If Val(Mid(xlApp.Version, 1, InStr(1, xlApp.Version, ".") - 1)) > 8 Then
-
'EXCEL 2000 or 2002: Use CopyFromRecordset
-
-
' Copy the recordset to the worksheet, starting in cell A2
-
xlWs.Cells(3, 1).CopyFromRecordset rst
-
'Note: CopyFromRecordset will fail if the recordset
-
'contains an OLE object field or array data such
-
'as hierarchical recordsets
-
-
Else
-
'EXCEL 97 or earlier: Use GetRows then copy array to Excel
-
-
' Copy recordset to an array
-
recArray = rst.GetRows
-
'Note: GetRows returns a 0-based array where the first
-
'dimension contains fields and the second dimension
-
'contains records. We will transpose this array so that
-
'the first dimension contains records, allowing the
-
'data to appears properly when copied to Excel
-
-
' Determine number of records
-
-
recCount = UBound(recArray, 2) + 1 '+ 1 since 0-based array
-
-
-
' Check the array for contents that are not valid when
-
' copying the array to an Excel worksheet
-
For iCol = 0 To fldCount - 1
-
For iRow = 0 To recCount - 1
-
' Take care of Date fields
-
If IsDate(recArray(iCol, iRow)) Then
-
recArray(iCol, iRow) = Format(recArray(iCol, iRow))
-
' Take care of OLE object fields or array fields
-
ElseIf IsArray(recArray(iCol, iRow)) Then
-
recArray(iCol, iRow) = "Array Field"
-
End If
-
Next iRow 'next record
-
Next iCol 'next field
-
-
' Transpose and Copy the array to the worksheet,
-
' starting in cell A2
-
xlWs.Cells(2, 1).Resize(recCount, fldCount).Value = _
-
TransposeDim(recArray)
-
End If
-
-
' Auto-fit the column widths and row heights
-
xlApp.Selection.CurrentRegion.Columns.AutoFit
-
xlApp.Selection.CurrentRegion.Rows.AutoFit
-
-
' Close ADO objects
-
rst.Close
-
cnt.Close
-
Set rst = Nothing
-
Set cnt = Nothing
-
-
' Release Excel references
-
Set xlWs = Nothing
-
Set xlWb = Nothing
-
-
Set xlApp = Nothing
-
-
End Sub
-
|
