Ciao a tutti,
volevo sapere se c'e' un modo per poter velocizzare l'importazione di un file excel su access di circa 20300 righe (che aumentano di circa 1000 o piu al mese) e 11 colonne.
Il codice e' il seguente
codice:
Private Sub bImportaFileControlli_Click()
    Dim ref As Reference
    
    ' 0 if Late Binding
    ' 1 if Reference to Excel set.
    #Const ExcelRef = 0
    #If ExcelRef = 0 Then ' Late binding EXE standAlone
        Dim objA As Object
        Dim objWB As Object
        Dim objWS As Object
        Set objA = CreateObject("Excel.Application")
        ' Remove the Excel reference if it is present   -   <=======
        On Error Resume Next
        Set ref = References!Excel
        If Err.Number = 0 Then
            References.Remove ref
        ElseIf Err.Number <> 9 Then 'Subscript out of range meaning not reference not found
            MsgBox Err.Description
            Exit Sub
        End If
    ' Use your own error handling label here
    ' On Error GoTo tagError '-  <=======
    #Else
        ' usate nell'IDE VB
        ' a reference to MS Excel <version number> Object Library must be specified
        Dim objA As Excel.Application
        Dim objWB As Excel.Workbook
        Dim objWS As Excel.Worksheet
        Set objA = New Excel.Application
    #End If
    
    Dim ColonnaPartenza As String
    Dim RigaPartenza As Integer
    Dim SQLAgg As String
    Dim SQLC As String, RSC As DAO.Recordset
    
    'For Each ref In Access.References
    '    Debug.Print ref.Name & " " & ref.FullPath & " " & ref.Major & "." & ref.Minor
    'Next ref
    'Exit Sub
    
    Dim dataEmail As String
    
    Dim fDialog As Office.FileDialog
    Dim varfile
    Dim FileDaImportare As String
    
    dataEmail = InputBox("Inserire data email di riferimento (es. 01/10/2015)")
    
    If dataEmail <> "" Then
        'controllo che se ci sono già pratiche con data email inserita
        If IsDate(Format(dataEmail, "mm/dd/yyyy")) = True Then
            SQLC = "SELECT TOP 1 dataEmail FROM pratiche_controlli_originale WHERE dataEmail='" & dataEmail & "' AND tipoImportazione=0"
            Set RSC = CurrentDb.OpenRecordset(SQLC)
            If RSC.EOF Then
                RSC.Close
                Set RSC = Nothing
                
                If dataEmail <> "" And IsDate(dataEmail) Then
                        ' Set up the File Dialog.
                        Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
                        
                        With fDialog
                        
                            ' Allow user to make multiple selections in dialog box
                            .AllowMultiSelect = False
                            
                            ' Set the title of the dialog box.
                            .Title = "Selezionare un file excel *.XLS"
                            
                            'imposto la cartella di partenza
                            .InitialFileName = "w:\prestitalia\"
                            
                            ' Clear out the current filters, and add our own.
                            .Filters.Clear
                            .Filters.Add "Microsoft Excel Workbooks", "*.xls;*.xlsx"
                            
                            ' Show the dialog box. If the .Show method returns True, the
                            ' user picked at least one file. If the .Show method returns
                            ' False, the user clicked Cancel.
                            If .Show = True Then
                            
                                'Loop through each file selected and add it to our list box.
                                For Each varfile In .SelectedItems
                                    FileDaImportare = varfile
                                Next
                                
                                'MsgBox FileDaImportare
                                                    
                                'objA.Visible = True
                                'apre il file
                                Set objWB = objA.Workbooks.Open(FileDaImportare)
                                'seleziona il foglio piu a sinistra (parte da 1)
                                Set objWS = objWB.Worksheets(1)
                                
                                'MsgBox objWS.Range("a1")
                                
                                'controllo se le colonne sono corrette altrimenti non importo il file
                                If InStr(LCase(objWS.Range("a1")), "pratica") < 1 Or IsNull(InStr(LCase(objWS.Range("a1")), "pratica")) Then
                                    MsgBox "Manca la colonna pratica nel file"
                                    objWB.Close SaveChanges:=False
                                    objA.Quit
                                    Set objA = Nothing
                                    Exit Sub
                                End If
                                
                                'If InStr(LCase(objWS.Range("j1")), "nota difformità") < 1 Or IsNull(InStr(LCase(objWS.Range("j1")), "nota difformità")) Then
                                '    MsgBox "Manca la colonna nota difformità nel file"
                                '    objWB.Close SaveChanges:=False
                                '    objA.Quit
                                '    Set objA = Nothing
                                '    Exit Sub
                                'End If
                                
                                'If InStr(LCase(objWS.Range("k1")), "nota avanzo") < 1 Or IsNull(InStr(LCase(objWS.Range("k1")), "nota avanzo")) Then
                                '    MsgBox "Manca la colonna nota avanzo nel file"
                                '    objWB.Close SaveChanges:=False
                                '    objA.Quit
                                '    Set objA = Nothing
                                '    Exit Sub
                                'End If
                                                    
                                Set DB = CurrentDb
                                
                                Set RS = DB.OpenRecordset("pratiche_controlli_originale")
                                
                                RigaPartenza = 2
                                
                                'Data = Format(ws.Range("f" & RigaPartenza), "mm/dd/yyyy")
                                                
                                DoCmd.OpenForm ("attendere")
                                PraticheGiaCaricate = ""
                                
                                'For I = RigaPartenza To 20000
                                I = RigaPartenza
                                While objWS.Range("a" & I) <> ""
                                    'inserisco nella tabella pratiche_assicurazioni_originale n° pratica e dataEmail
                                    'mi serve come tabella di appoggio per poi esportare il file delle pratiche che
                                    'fra spedisce a roma
                                    SQLOrig = "INSERT INTO pratiche_controlli_originale (pratica, dataEmail, tipoImportazione) " & _
                                    " VALUES (" & objWS.Range("a" & I) & ",#" & Format(CDate(dataEmail), "mm/dd/yyyy") & "#, 0)"
                                    CurrentDb.Execute (SQLOrig)
                                    
                                    DoEvents
                                    I = I + 1
                                'Next
                                Wend
                                
                                DoCmd.Close acForm, "attendere"
                                
                                RS.Close
                                DB.Close
                                
                                objWB.Close SaveChanges:=False
                                objA.Quit
                                Set objA = Nothing
                                
                                MsgBox "Importazione file terminata."
                            Else
                                'MsgBox "You clicked Cancel in the file dialog box."
                            End If
                        End With
                Else
                    MsgBox "Attenzione inserire una data valida"
                End If
            Else
                RSC.Close
                Set RSC = Nothing
                MsgBox "Attenzione esiste gia' una lista con la dataEmail inserita: " & dataEmail
            End If
        Else
            RSC.Close
            Set RSC = Nothing
            MsgBox "Attenzione la dataEmail inserita non e' valida: " & dataEmail
        End If
    End If
End Sub