Newsgroup: it.comp.lang.visual-basic
Titolo: Esportazione dati su Excel

Come fare per esportare i dati raccolti in un recordset in un foglio di
Excel da creare al momento?


Ti posto una mia vecchia routine che uso da parecchio e che non mi ha mai
creato problemi.
ciao
ugo
p.s.
programma.rel = app.Major & "." & app.Minor & app.Revision
ShowerrMsg = mia routine di gesione errori
Eseguo un loop in + sul Rs per evitare grane con i Null e rettificare i
valori per excel.
spero di non avere dimenticato altro.
ri-ciao
ugo
Sub ToExcel(rsData As ADODB.Recordset, sName As String)
    Dim TempArray()
    Dim exclApp As Object
    Dim WKS As Object
    Dim NN, KK As Integer
    Dim nFieldsCount, nRecordCount As Long
    On Error GoTo err
    'Rettifico il Nome Foglio
    sName = Replace(Replace(Replace(sName, ":", ""), "\", ""), "/", "")
    sName = Replace(Replace(Replace(Replace(sName, "?", ""), "*", ""), "[",
""), "]", "")
    'First, start Excel
    Set exclApp = GetObject(, "Excel.Application")
resuming:
    'preparo Excel
    With exclApp
        .Visible = True
        With .activeWorkbook
            Set WKS = .Worksheets.Add
            For NN = 1 To .Sheets.Count
                If sName = .Sheets(NN).Name Then
                    sName = sName + "-nuovo"
                End If
            Next NN
        End With
    End With
    sName = Left(sName, 31)
    With WKS
        .cells.Delete
        .cells(1, 1) = App.FileDescription & "  " & Programma.Release & " -
Esportazione Dati."
        .cells(2, 1) = "Attendere, lettura dati in corso: " & sName
    End With
    With rsData
        nFieldsCount = .Fields.Count
        nRecordCount = .RecordCount
    End With
    If nRecordCount = 0 Then
        With WKS
            .cells(4, 1) = "NESSUN dato disponibile"
            .cells(4, 1).Font.Bold = True
        End With
    Else
        'Riporto il Recordset su Un Array, per pulire i NULL
        ReDim TempArray(1 To nRecordCount, 1 To nFieldsCount)
        For NN = 1 To nRecordCount
            WKS.cells(4, 1) = "Conversione in corso record: " & str(NN) & "
/ " & nRecordCount
            DoEvents
            For KK = 1 To nFieldsCount
                If IsNull(rsData(KK - 1)) Then
                    TempArray(NN, KK) = Empty
                ElseIf VarType(rsData(KK - 1)) = vbString And
Left(rsData(KK - 1), 1) = "=" Then
                    TempArray(KK, KK) = "'" + rsData(KK - 1)
                Else
                    TempArray(NN, KK) = rsData(KK - 1)
                End If
            Next KK
            rsData.MoveNext
        Next NN
        'Carico lo sheet con i dati
        With WKS
            For KK = 0 To nFieldsCount - 1
                .cells(1, KK + 1).Value = rsData.Fields(KK).Name
            Next KK
            .Range(WKS.cells(1, 1), WKS.cells(1, nFieldsCount)).Font.Bold =
True
            'WK.Range("A2").CopyFromRecordset rsData
            .Range("A2").Resize(rsData.RecordCount,
rsData.Fields.Count).Value = TempArray
            .cells(2, 1).Activate
            For KK = 0 To nFieldsCount - 1
                .Columns.AutoFit
            Next KK
            .Name = sName
        End With
    End If
    'Chiusura degli oggetti aperti
    rsData.Close
    Set rsData = Nothing
    Set exclApp = Nothing
    Set WKS = Nothing
    Screen.MousePointer = 0
    Exit Sub
err:
    If err = 429 Then
        err.Clear
        Set exclApp = CreateObject("Excel.Application")
        exclApp.Workbooks.Add
        Resume resuming
    Else
        ShowErrMsg
    End If
    Screen.MousePointer = 0
End Sub