Creating Excel File from iterating ado recordset

Hi jupiterz,

Please confirm my understanding of your requirements:

You execute a SQL statement from your Visual Basic code a number of times that has a dynamically changing WHERE clause.

Every time a SQL statement is executed you wish to create an entry in an MS-Excel worksheet that states the <...and here's where I'm struggling...> SQL Statement / WHERE clause only / results (delete as applicable).


Thank you for your clarification.


BFN,

fp.

http://www.vb-helper.com/howto_access_to_excel_2.html

http://www.vb-helper.com/howto_access_to_excel.html

I have a simple example, but it can get more complicated if you want to format the columns.

First you create your data:

DIm GF as New zGF ' agin access to your function library

RS.Open.....etc I assume you can do this

' convert the recorset RS to a string
' and move the string to Excel
OK=ExcelCreateOK(GF.Expose(RS, True))

'Job Done.


----------------------Exctract from class zGF
Public Function ExcelCreateOK(FromData As String) As Boolean

' Fires Up Excel and pastes data into a new workbook

' See class zExcel for a better version of this

' OK = GF.ExcelCreateOK(sDataToPaste)


On Error Resume Next

Dim ExcelApp
Set ExcelApp = CreateObject("Excel.Application")
Dim WB

ExcelApp.Visible = True
Set WB = ExcelApp.Workbooks.Add
WB.Activate
ExcelApp.Range("A1").Select

Clipper FromData

ExcelApp.ActiveSheet.Paste
Set WB = Nothing
Set ExcelApp = Nothing
If Err.Number = 0 Then
    ExcelCreateOK = True
End If

End Function


Function Expose(RS, Optional ExcelFormat As Boolean = True) As String

' Display the contents of  recordsset

Dim sRow As String
Dim sDocument As String
Dim fc As Long
Dim rc As Long
Dim sDelim As String

If RS Is Nothing Then
    Expose "Recordset Is Nothing"
    Exit Function
End If
If RS.EOF And RS.BOF Then
    Expose "Recordset Empty"
    Exit Function
End If

Dim bm

' you may want to retain bookmark
'On Error Resume Next
'bm = RS.Bookmark


RS.MoveFirst

' create column headings

If ExcelFormat Then
    sRow = ""
    For fc = 0 To RS.Fields.Count - 1
        sRow = sRow + sDelim + RS.Fields(fc).Name
        sDelim = Chr(9)
    Next
    sDocument = sRow
End If



Do While Not RS.EOF
    If ExcelFormat Then
        sRow = ""
        sDelim = ""
        For fc = 0 To RS.Fields.Count - 1
            sRow = sRow + sDelim + GetFieldDisplayFormat(RS(fc))
            sDelim = Chr(9)
        Next fc
        sDocument = sDocument + sRow + vbCrLf
    Else
        sRow = "Row:" + CStr(rc)
        For fc = 0 To RS.Fields.Count - 1
            sRow = sRow + "; " + RS(fc).Name + ": " + GetFieldDisplayFormat(RS(fc))
        Next fc
        sDocument = sDocument + sRow + vbCrLf
    End If
    rc = rc + 1
    RS.MoveNext
Loop

Expose = sDocument
'On Error Resume Next
'RS.Bookmark = bm


End Function

Function GetFieldDisplayFormat(RSField, Optional NullValue = "Null") As String

' Converts a Field into a string


Dim tp$, fmt$

' obtain a simple type for the field
' B=binary, D=Date, N=Numeric, S or M are strings
GetFieldSimpleType RSField.Type, tp, fmt
Dim d$
If IsNull(RSField) Then
    d$ = ""
    Exit Function
End If
Select Case tp
    Case Is = "B"
        If IsNull(RSField) Then
            d$ = NullValue
        Else
            d$ = Format(RSField, fmt)
        End If
    Case Is = "D"
        If IsNull(RSField) Then
            d$ = NullValue
        Else
            d$ = Format(RSField, fmt)
        End If
    Case Is = "N"
        If IsNull(RSField) Then
            d$ = NullValue
        Else
            d$ = Format(RSField, fmt)
        End If
    Case Else
        If IsNull(RSField) Then
            d$ = NullValue
        Else
            d = CStr(RSField)
        End If
End Select

       
GetFieldDisplayFormat = d$

End Function

Sub GetFieldSimpleType(TypeCode, tp As String, fmt As String)

' returns a simplefied data type from an ad?? Type code
' also sets up a default format

' Need to add reference to ADOX
' MS ADO Ext for DLL & Security

Select Case TypeCode
        Case Is = ADOX.DataTypeEnum.adBoolean
            tp = "B": fmt = "Yes/No"
        Case Is = ADOX.DataTypeEnum.adDate
            tp = "D": fmt = DateFormat
        Case Is = ADOX.DataTypeEnum.adDBDate
            tp = "D": fmt = DateFormat
        Case Is = ADOX.DataTypeEnum.adDBTime
            tp = "D": fmt = DateFormat
        Case Is = ADOX.DataTypeEnum.adDBTimeStamp
            tp = "D": fmt = DateFormat
        Case Is = ADOX.DataTypeEnum.adVarChar
            tp = "T"
        Case Is = ADOX.DataTypeEnum.adVarWChar
            tp = "T"
        Case Is = ADOX.DataTypeEnum.adWChar
            tp = "T"
        Case Is = ADOX.DataTypeEnum.adChar
            tp = "T"
        Case Is = ADOX.DataTypeEnum.adLongVarChar
            tp = "M"
        Case Is = ADOX.DataTypeEnum.adLongVarWChar
            tp = "M"
        Case Is = ADOX.DataTypeEnum.adCurrency
            tp = "N": fmt = CurrrencyFormat
        Case Else
            tp = "N"
            'sz = .NumericScale
            'If sz > 0 Then
            '    fmt = "0." + String(sz, "0")
            'Else
                fmt = "0"
            'End If
    End Select
End Sub

For the above you need to add to your function lib.
Const CurrrencyFormat As String = "0.00" ' change as required

Handy tip.......

If you declare your function library in a module like "Global GF as New zGF" then when you are debugging your program you can get see what is in you recordset using the immediate window:

?GF.Expose(RS)

Or to place the contents of the RS into the clipboard for paste into notepad:

GF.Clipper GF.Expose(RS)

Or to show in Excel

ExcelCreateOK GF.Expose(RS, True)

PS the fastest way to get data into excel is via the clipboard using Paste.  You can create a sheet cell by cell but it is very slow.

It is quicker to load your data in a paste and then adjust column sizes as require usign code like this:

Set EA = CreateObject("Excel.Application")

EA.Visible = False
Set WB = EA.Workbooks.Add
WB.Activate

' define font
EA.cells.Select
With EA.selection.Font
    .Name = "Arial"
    .Size = 8
    .Strikethrough = False
    .superScript = False
    .subScript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = zxlUnderlineStyleNone
    .ColorIndex = zxlAutomatic
End With
EA.selection.Font.Bold = False

Dim lc As Long


lc = 0
Do While lc <= mlColumns
   
    EA.Columns(mvColdata(lc).Name + ":" + mvColdata(lc).Name).Select
    With EA.selection
        .VerticalAlignment = &HFFFFEFF5 'Excel.Constants.xlBottom
        .WrapText = False
        .Orientation = 0
        .IndentLevel = 0
        .ShrinkToFit = False
        .MergeCells = False
        If Len(mvColdata(lc).FormatSpec) > 0 Then
            On Error Resume Next
            .NumberFormat = mvColdata(lc).FormatSpec
            On Error GoTo 0
        End If
        If mvColdata(lc).Characters > 0 Then
            .ColumnWidth = mvColdata(lc).Characters
        End If
       
        Select Case mvColdata(lc).align
            Case Is = zExAlignment.zexLeft
                '.HorizontalAlignment = Excel.Constants.xlLeft
                .HorizontalAlignment = &HFFFFEFDD  'left
            Case Is = zExAlignment.zexright
                 .HorizontalAlignment = &HFFFFEFC8  'right
            Case Else
                .HorizontalAlignment = &HFFFFEFF4   'center
        End Select
       
    End With
   
    lc = lc + 1
Loop

EA.Range("A1").Select


If Len(DataToPaste) > 0 Then
    Clipboard.Clear
    Clipboard.SetText DataToPaste
    EA.ActiveSheet.Paste 'paste into excel
    Clipboard.Clear
End If

A little example:

Private Sub PrintPartij()
'## The sub PrintPrintOverzicht will print (to excell), the paknumbers where is a mistake in the name of the list
On Error GoTo PrintPartijError
    Dim xSql As String
    Dim OldSql As String
    Dim Grafiek As String
  dim adoCN as ADODB.Connection
  dim adoRS as ADODB.Recordset    

    xSql = "SELECT* from YourTable WHERE ...    "    Set adoCn = New ADODB.Connection
    adoCn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=YourDatabase.mdb"
    Set adoRs = New ADODB.Recordset
    adoRs.Open xSql, adoCn, adOpenKeyset
   
    Dim ExcelApp As Object
    Dim ExcelWorkBook As Object
    Dim i As Integer
   
    Set ExcelApp = CreateObject("excel.application")
    ExcelApp.Visible = False
   
    Set ExcelWorkBook = ExcelApp.Workbooks.Add
    With adoRs ' recordset
        ' Printing the fields into excell !
        ExcelWorkBook.sheets(1).cells(adoRs.AbsolutePosition, 1) = "Field1"
        ExcelWorkBook.sheets(1).cells(adoRs.AbsolutePosition, 2) = "Field2"
        ExcelWorkBook.sheets(1).cells(adoRs.AbsolutePosition, 3) = "Field3"
        ExcelWorkBook.sheets(1).cells(adoRs.AbsolutePosition, 4) = "Field4"
        Do Until .EOF
            For i = 0 To adoRs.Fields.Count - 1
                ExcelWorkBook.sheets(1).cells(adoRs.AbsolutePosition + 1, i + 1) = Trim(adoRs.Fields(i))
            Next i
            .MoveNext
        Loop
    End With
    ExcelApp.Visible = True
   
    adoRs.Close
    adoCn.Close
   
    Set ExcelWorkBook = Nothing
    Set ExcelApp = Nothing
    Set adoRs = Nothing
    Set adoCn = Nothing
   
    Check2(6).Value = 0
    Exit Sub
PrintPartijError:
    LogError "Socver-PrintPartij", Err.Number, Err.Description
    Resume Next
End Sub

Hi all,

Thanks for your answers. I really do not know if all your answers satisfy my need.
My requirement is here again:

For i = 1 to 10
     adoRS = executeQuery
     For j = 1 to adoRS.RecordCount
          WriteRsToExcel
     Next j
next i    

My question how can I keep writing to the same excel file if the same query executes 10 times, with different results. The criteria changes in the whereclause (executeQuery) each time it loops resulting in a adoRS with different RecordCount but same attributes.

Warning RecordCount is not always accurate.  See the Sub Expose for a better way of looping a recordset. Keep going until adoRS.EOF.  This also solves the problem that the code won't crash if the recorset was empty.

For i = 1 to 10
     adoRS = executeQuery
     Do While Not adoRS.EOF ' better way
          WriteRsToExcel
     Loop
next i    

I respectfully suggest the question be closed & points awarded accordingly; probably to "inthedark" as [s]he spent so much time replying!

Thank you.