il mio codice è questo:


Option Explicit

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OpenFileNameType) As Long

Private Type OpenFileNameType
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type


Public Function OpenFileName(sTitle As String, sPath As String, sFilter As String, hWnd As Long) As String
' esempio di utilizzo delle api al posto della commondialog ocx
Dim OpenFile As OpenFileNameType
Dim lReturn As Long
OpenFileName = ""

lReturn = GetOpenFileName(OpenFile)
If lReturn = 0 Then
OpenFileName = ""
Else
OpenFileName = Trim(OpenFile.lpstrFile)
End If
End Function


Public Sub Ado2Excel(rsData As ADODB.Recordset, sName As String, bCheck As Boolean)
' Parametri:
' rsData - Recordset ADO da esportare
' sName - nome da assegnare allo sheet di excel
' bCheck - eseguire un controllo sui dati
'
Dim TempArray()
Dim exclApp As Object
Dim WKS As Object
Dim NN, KK As Integer
Dim nFieldsCount As Integer, nRecordCount As Long
On Error GoTo err
Screen.MousePointer = vbHourglass
'Rettifico il Nome Foglio (giusto per dormire tranquillo!):
sName = Replace(Replace(Replace(sName, ":", ""), "\", ""), "/", "")
sName = Replace(Replace(Replace(Replace(sName, "?", ""), "*", ""), "[", ""), "]", "")
'dichiaro una variabile excel.application
Set exclApp = GetObject(, "Excel.Application")
'...e in caso di errore gestisco l'errore e apro excel...
Resuming:
With exclApp
.Visible = True

With .ActiveWorkbook
Set WKS = .Worksheets.Add
' Verifico se già esiste un foglio con lo stesso nome
For NN = 1 To .Sheets.Count
If sName = .Sheets(NN).Name Then
sName = sName + "-nuovo"
End If
Next NN
End With
End With
'Assumo comunque che mi bastino 31 char...
sName = Left(sName, 31)
With WKS
.Cells.Delete
.Cells(1, 1) = App.Title & " " & App.Major & "." & App.Minor & "." & Trim(App.Revision) & " - 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
If bCheck Then
'Riporto il Recordset su Un Array, per pulire i NULL ed altro
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
' Pulisco i NULL
TempArray(NN, KK) = Empty
ElseIf VarType(rsData(KK - 1)) = vbString And Left(rsData(KK - 1), 1) = "=" Then
' Pulisco gli "="
TempArray(KK, KK) = "'" + rsData(KK - 1)
Else
TempArray(NN, KK) = rsData(KK - 1)
End If
Next KK
rsData.MoveNext
Next NN
End If
'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
If Not bCheck Then
'Se non è richiesto il controllo uso il metodo standard
.Range("A2").CopyFromRecordset rsData
Else
'Avendo eseguito il controllo dei dati uso l'array
.Range("A2").Resize(rsData.RecordCount, rsData.Fields.Count).Value = TempArray
End If
.Cells(2, 1).Activate
' .Columns.AutoFit
.Columns("A").columnWidth = "10.57"
.Columns("B").columnWidth = "10.57"
.Columns("C").columnWidth = "11.14"
.Columns("D").columnWidth = "10.00"
.Columns("E").columnWidth = "04.86"
.Columns("F").columnWidth = "06.86"
.Columns("G").columnWidth = "28.86"
.Columns("H").columnWidth = "16.14"
.Columns("I").columnWidth = "40.29"
.Columns("J").columnWidth = "07.14"
.Name = sName
End With
End If
WKS.SaveAs "C:\" & sName
'Chiusura degli oggetti aperti:
'Disattivo la set nothing dell'oggetto recordset perchè
' la esegue la routine chiamante...
'Set rsData = Nothing
Set exclApp = Nothing
Set WKS = Nothing
Screen.MousePointer = 0
Exit Sub
err:
If err = 429 Then
'Se Excel non è aperto
err.Clear
Set exclApp = CreateObject("Excel.Application")
exclApp.Workbooks.Add
Resume Resuming
Else
'ShowErrMsg
End If
Screen.MousePointer = 0
End Sub