Scrivere su file excel da access con vba

di il
5 risposte

Scrivere su file excel da access con vba

Ciao, sto utilizzando questo codice per scrivere su dei file excel. Naturalmente non funziona, qualche volta mi salva una copia del file excel e qualche altra (più spesso) non scrive nulla sull'excel. Non so dove sia l'errore
Public Function ExportExcel()
   
   Dim db As DAO.Database, RstUpdt As DAO.Recordset, RstApp As DAO.Recordset, RstDel As DAO.Recordset, Tbf As DAO.TableDef, FldNum As Integer
   Dim xlx As Object, xlw As Object, xls As Object, xlc As Object
   Dim blnEXCEL As Boolean, FileName As String, WorksheetName As String, CellRange As Range
   Dim Fld As DAO.Field, FldName As String, FldValue As Variant
   Dim Idx As Index, i As Integer, ColNum As Integer
   Dim TbEx As String, ColName As String, RowNum As Long
     
   Set db = CurrentDb
   
   
   ' stabilisce un'applicazione oggetto excel
   blnEXCEL = False
   On Error Resume Next
   Set xlx = GetObject(, "Excel.application")
   If Err.Number <> 0 Then
      Set xlx = CreateObject("Excel.application")
      blnEXCEL = True
   End If
   Err.Clear
   On Error GoTo 0
   xlx.Visible = False ' se setto vero mi apre il file excel in questione
   
   For Each Tbf In db.TableDefs
      On Error Resume Next
      TbEx = Tbf.Name & "Ex"
      
      If ifTableExists(TbEx) Then 'controlla se esiste la tabella collegata (per evitare tabelle che non ho esportato)
         Debug.Print (TbEx)
         Set Fld = Tbf.Fields
         
         For Each Idx In Tbf.Indexes ' cerca tra i campi della tabella quali sono i primary key
            
            If Idx.Primary Then
               Fld = Idx.Fields
               FldName = Replace(Idx.Fields, "+", "") 'ritorna il nome del campo primary key
               Debug.Print (FldName)
               Set RstUpdt = db.OpenRecordset("SELECT [" & Tbf.Name & "].* FROM [" & TbEx & "] INNER JOIN [" & Tbf.Name & "] ON [" & TbEx & "].[" & FldName & "] = [" & Tbf.Name & "].[" & FldName & "] " & vbCrLf & _
                                              "WHERE ((([" & Tbf.Name & "].[Data/ora modifica])>[" & TbEx & "].[data/ora modifica]));")

               
               Set RstApp = db.OpenRecordset("SELECT [" & Tbf.Name & "].* FROM [" & Tbf.Name & "] LEFT JOIN [" & TbEx & "] ON [" & Tbf.Name & "].[" & FldName & "] = [" & TbEx & "].[" & FldName & "] WHERE ((([" & TbEx & "].[" & FldName & "]) Is Null));")
               Set RstDel = db.OpenRecordset("SELECT [" & TbEx & "].[" & FldName & "], [" & TbEx & "].[Data/ora creazione], [" & TbEx & "].[Data/ora modifica] " & vbCrLf & _
                                             "FROM [" & TbEx & "] LEFT JOIN [" & Tbf.Name & "] ON [" & TbEx & "].[" & FldName & "] = [" & Tbf.Name & "].[" & FldName & "] " & vbCrLf & _
                                             "WHERE ((([" & Tbf.Name & "].[" & FldName & "]) Is Null));")
               
               
               RstUpdt.MoveLast '!!!
               RstApp.MoveLast
               RstDel.MoveLast
               Debug.Print (RstUpdt.RecordCount)
               Debug.Print (RstApp.RecordCount)
               Debug.Print (RstDel.RecordCount)
            
               If RstUpdt.RecordCount > 0 Or RstApp.RecordCount > 0 Or RstDel.RecordCount > 0 Then 'se ci sono record allora faccio l'update del file
                  FileName = "C:\Users\diego\OneDrive - Indipendente\Lavoro\Informatica\Gestionale\Dati\" & Tbf.Name & ".xlsx"
                  Set xlw = xlx.Workbooks.Open(FileName)
                  Debug.Print (FileName)
                  WorksheetName = Tbf.Name
                  Set xls = xlw.Worksheets(WorksheetName)
                  FldNum = CurrentDb.TableDefs(Tbf.Name).Fields.Count ' numero di campi nella tabella
                  Debug.Print (CurrentDb.TableDefs(Tbf.Name).Fields.Count)
                  Debug.Print (WorksheetName)
                  Debug.Print (FldNum)
                  For i = 1 To FldNum ' trovo la colonna corrispettiva in excel del campo access: cerco dalla prima colonna della prima riga fino al numero di campi della tabella access se il nome campo access è uguale all'intestazione colonna di excel
                     Debug.Print (xls.Cells(1, i).Value)
                        If xls.Cells(1, i).Value = FldName Then
                           ColName = (Left(Right(xls.Cells(1, i).Address, Len(xls.Cells(1, i).Address) - 1), InStr(xls.Cells(1, i).Address, "$")))
                           Debug.Print (ColName)
                           Exit For
                        End If
                  Next i
                  
                  If RstUpdt.RecordCount > 0 Then
                     RstUpdt.MoveFirst
                     Do While Not RstUpdt.EOF Or RstUpdt.BOF
                        Debug.Print (RstUpdt.Fields(FldName))
                        FldValue = RstUpdt.Fields(FldName)
                        Set xlc = xls.Range(ColName & ":" & ColName).Find(FldValue) 'Rstupdt.Fields(FldName))
                        Debug.Print (xlc)
                        RowNum = xlc.Row
                        Debug.Print (RowNum)
                        For ColNum = 0 To FldNum - 1
                           xlc.Offset(0, ColNum).Value = RstUpdt.Fields(ColNum).Value
                           Debug.Print (xlc.Offset(0, ColNum).Value)
                           Debug.Print (RstUpdt.Fields(ColNum).Value)
                        Next ColNum
                        RstUpdt.MoveNext
                     Loop
                  End If
                  
               End If
               
            End If
         Next Idx
      End If
   xlx.DisplayAlerts = False
      xlw.Save
      xlw.Close
   xlx.DisplayAlerts = True

   Next Tbf
   
   Set xlc = Nothing
   Set xls = Nothing
   Set xlw = Nothing

   If blnEXCEL = True Then xlx.Quit ' se esiste l'applicazione excel la chiude
   Set xlx = Nothing
   

End Function

5 Risposte

  • Re: Scrivere su file excel da access con vba

    Non so cosa devi fare veramente, ma una semplice ESPORTAZIONE non va bene? Puoi farla manualmente con i comandi nativi di Access. Puoi farlo in VBA con DoCmd.OutputTo.
  • Re: Scrivere su file excel da access con vba

    diegomarino80 ha scritto:


    ...Non so dove sia l'errore
    Comincia con il fartelo dire dal codice. Mi spiego.
    Diamo per assodata la presenza della dichiarazione Option Explicit in tutti i moduli che aiuta a rilevare gli errori di digitazione con l'uso di variabili non dichiarate (però guarda, che non sia tutto lì perché allora... )
    ...
       For Each Tbf In db.TableDefs
          On Error Resume Next
          TbEx = Tbf.Name & "Ex"
          
          If ifTableExists(TbEx)
    ...
    Nella seconda riga dici a VBA di ignorare ogni errore e proseguire: no! Gli errori si prevengono e si gestiscono. L'uso di Resume Next deve essere fatto con molta attenzione, come ad esempio nelle righe iniziali in cui usi un'istanza di Excel già presente oppure ne apri una se questa non c'è. Vedi che però il tutto è racchiuso in pochissime righe, poi gli errori tornano ad essere evidenziati con un On Error GoTo 0

    Usi la funzione ifTableExists di cui non sappiamo nulla. Magari il problema non è lì però per noi è impossibile dirlo.
    ...
    FileName = "C:\Users\diego\OneDrive - Indipendente\Lavoro\Informatica\Gestionale\Dati\" & Tbf.Name & ".xlsx"
    ...
    Non uso OneDrive quindi non so come funziona ma per le prove usa percorsi locali, al massimo percorsi su LAN, in modo da escludere problemi "di internet".
  • Re: Scrivere su file excel da access con vba

    Purtroppo non posso usare una esportazione semplice, perché quegli excel li uso come dati in powerapps.

    la funzione è questa, controlla solo se esiste la tabella-copia collegata che sarebbe l'excel
    Public Function ifTableExists(tblName As String) As Boolean 'vedere se una tabella esiste
        If DCount("[Name]", "MSysObjects", "[Name] = '" & tblName & "'") = 1 Then
            ifTableExists = True
        End If
    End Function
    
    per quanto riguarda onedrive il percorso dovrebbe essere locale.

    Cmq, ho ricostruito daccapo tutto e funzionava, arrivato ad un certo step ha smesso di nuovo di funzionare. Cerco di capire qual è lo step incriminato

    EDIT! penso di aver capito il problema, dopo "xlw.save" devo mettere "xlw.close"! e non metterlo alla fine.
    Vediamo se è questo
  • Re: Scrivere su file excel da access con vba

    Quello era un problema, ora ce n'è un altro che non capisco.
    questa configurazione funziona (ps poi tolgo i resume next)
    Public Function ExportExcel()
       Dim xlx As Object, xlw As Object, xls As Object, xlc As Object
       Dim db As DAO.Database, Tbf As DAO.TableDef, RstUpdt As DAO.Recordset
       Dim i As Integer
       Dim TbEx As String, FldName As String
       
       Set db = CurrentDb
       On Error Resume Next
       Set xlx = GetObject(, "Excel.application")
       If Err.Number <> 0 Then
          Set xlx = CreateObject("Excel.application")
       End If
       Err.Clear
       On Error GoTo 0
       xlx.Visible = False ' se setto vero mi apre il file excel in questione
       
       For Each Tbf In db.TableDefs
          TbEx = Tbf.Name & "ex"
          If ifTableExists(TbEx) Then
             FldName = GetIndex(Tbf)
             Debug.Print (FldName)
          
             Set xlw = xlx.Workbooks.Open("C:\Users\diego\OneDrive - Indipendente\Lavoro\Informatica\Gestionale\Dati\" & Tbf.Name & ".xlsx")
             Set xls = xlw.worksheets(Tbf.Name)
             Set RstUpdt = db.OpenRecordset("SELECT [" & Tbf.Name & "].* FROM [" & TbEx & "] INNER JOIN [" & Tbf.Name & "] ON [" & TbEx & "].[" & FldName & "] = [" & Tbf.Name & "].[" & FldName & "] " & vbCrLf & _
                                            "WHERE ((([" & Tbf.Name & "].[Data modifica])>[" & TbEx & "].[data modifica]));")
            
             RstUpdt.MoveLast
             Debug.Print (RstUpdt.RecordCount)
             'Set RstUpdt = db.OpenRecordset("SELECT * FROM " & Tbf.Name)
             If RstUpdt.RecordCount > 0 Then
                Set xlc = xls.Range("a1")
                
                Do While Not RstUpdt.EOF
                   For i = 0 To RstUpdt.Fields.Count - 1
                   'xlc.Offset(0, ColNum).Value = RstUpdt.Fields(ColNum).Value
                      xlc.Offset(1, i).Value = RstUpdt.Fields(i).Value
                   Next i
                   RstUpdt.MoveNext
                   Set xlc = xlc.Offset(1, 0)
                Loop
                
             End If
             
          xlw.Save
          xlw.Close
          End If
       Next Tbf
    
       Set xlc = Nothing
       Set xls = Nothing
       Set xlw = Nothing
       xlx.Quit ' se esiste l'applicazione excel la chiude
       Set xlx = Nothing
    
    End Function
    
    quest'altra no, anche se ha più senso, ovvero spostando il setting del recordset a prima la definizione degli oggetti xlw e xls.
    Public Function ExportExcel()
       Dim xlx As Object, xlw As Object, xls As Object, xlc As Object
       Dim db As DAO.Database, Tbf As DAO.TableDef, RstUpdt As DAO.Recordset
       Dim i As Integer
       Dim TbEx As String, FldName As String
       
       Set db = CurrentDb
       On Error Resume Next
       Set xlx = GetObject(, "Excel.application")
       If Err.Number <> 0 Then
          Set xlx = CreateObject("Excel.application")
       End If
       Err.Clear
       On Error GoTo 0
       xlx.Visible = False ' se setto vero mi apre il file excel in questione
       
       For Each Tbf In db.TableDefs
          TbEx = Tbf.Name & "ex"
          If ifTableExists(TbEx) Then
             FldName = GetIndex(Tbf)
             Debug.Print (FldName)
          
             Set RstUpdt = db.OpenRecordset("SELECT [" & Tbf.Name & "].* FROM [" & TbEx & "] INNER JOIN [" & Tbf.Name & "] ON [" & TbEx & "].[" & FldName & "] = [" & Tbf.Name & "].[" & FldName & "] " & vbCrLf & _
                                            "WHERE ((([" & Tbf.Name & "].[Data modifica])>[" & TbEx & "].[data modifica]));")
            
             RstUpdt.MoveLast
             Debug.Print (RstUpdt.RecordCount)
             'Set RstUpdt = db.OpenRecordset("SELECT * FROM " & Tbf.Name)
             If RstUpdt.RecordCount > 0 Then
                Set xlw = xlx.Workbooks.Open("C:\Users\diego\OneDrive - Indipendente\Lavoro\Informatica\Gestionale\Dati\" & Tbf.Name & ".xlsx")
                Set xls = xlw.worksheets(Tbf.Name)
                Set xlc = xls.Range("a1")
                
                Do While Not RstUpdt.EOF
                   For i = 0 To RstUpdt.Fields.Count - 1
                   'xlc.Offset(0, ColNum).Value = RstUpdt.Fields(ColNum).Value
                      xlc.Offset(1, i).Value = RstUpdt.Fields(i).Value
                   Next i
                   RstUpdt.MoveNext
                   Set xlc = xlc.Offset(1, 0)
                Loop
                
             End If
             
          xlw.Save
          xlw.Close
          End If
       Next Tbf
    
       Set xlc = Nothing
       Set xls = Nothing
       Set xlw = Nothing
       xlx.Quit ' se esiste l'applicazione excel la chiude
       Set xlx = Nothing
    
    End Function

    non so perché accada onestamente
  • Re: Scrivere su file excel da access con vba

    Risolto! ora funziona tutto. Per chi volesse dare un'occhiata il codice è qui

    tutto ciò serve ad aggiornare i file excel che sono collegati a tabelle access.
    questo codice controlla solo se ci sono divergenze nei campi "data/ora modifica", devo solo aggiungere la parte per aggiungere i record nuovi non presenti e cancellare le righe dei record che cancello su access
    Public Function ExportExcel()
       Dim xlx As Object, xlw As Object, xls As Object, xlc As Object
       Dim db As DAO.Database, Tbf As DAO.TableDef, RstUpdt As DAO.Recordset
       Dim Worksheetname As String, TbEx As String, FldName As String, ColName As String
       Dim FldNum As Integer, i As Integer, RowNum As Long
       Dim FldValue As Variant
       
       Set db = CurrentDb
       On Error Resume Next
       Set xlx = GetObject(, "Excel.application")
       If Err.Number <> 0 Then
          Set xlx = CreateObject("Excel.application")
       End If
       Err.Clear
       On Error GoTo 0
       xlx.Visible = False ' se setto vero mi apre il file excel in questione
       
       For Each Tbf In db.TableDefs
          TbEx = Tbf.Name & "ex"
          If ifTableExists(TbEx) Then
             FldName = GetIndex(Tbf)
             Debug.Print (FldName)
          
             Set xlw = xlx.Workbooks.Open("C:\Users\diego\OneDrive - Indipendente\Lavoro\Informatica\Gestionale\Dati\" & Tbf.Name & ".xlsx")
             Set xls = xlw.worksheets(Tbf.Name)
          
             Set RstUpdt = db.OpenRecordset("SELECT [" & Tbf.Name & "].* FROM [" & TbEx & "] INNER JOIN [" & Tbf.Name & "] ON [" & TbEx & "].[" & FldName & "] = [" & Tbf.Name & "].[" & FldName & "] " & vbCrLf & _
                                            "WHERE ((([" & Tbf.Name & "].[Data modifica])>[" & TbEx & "].[data modifica]));")
            
             RstUpdt.MoveLast
             Debug.Print (RstUpdt.RecordCount)
             'Set RstUpdt = db.OpenRecordset("SELECT * FROM " & Tbf.Name)
             If RstUpdt.RecordCount > 0 Then
                RstUpdt.MoveFirst
                FldNum = RstUpdt.Fields.Count
                ColName = GetExcelColumn(FldNum, xls, FldName)
                Debug.Print (ColName)
    
                
                Do While Not RstUpdt.EOF Or RstUpdt.BOF
                   Debug.Print (RstUpdt.Fields(FldName))
                   FldValue = RstUpdt.Fields(FldName)
                   Set xlc = xls.Range(ColName & ":" & ColName).Find(FldValue) 'Rstupdt.Fields(FldName))
                   Debug.Print (xlc)
                   RowNum = xlc.Row
                   Debug.Print (RowNum)
                   For i = 0 To FldNum - 1
                      'xlc.Offset(0, ColNum).Value = RstUpdt.Fields(ColNum).Value
                      xlc.Offset(0, i).Value = RstUpdt.Fields(i).Value
                      Debug.Print (xlc.Offset(0, i).Value)
                      Debug.Print (RstUpdt.Fields(i).Value)
                   Next i
                   RstUpdt.MoveNext
                Loop
                
             End If
             
          xlw.Save
          xlw.Close
          End If
       Next Tbf
    
       Set xlc = Nothing
       Set xls = Nothing
       Set xlw = Nothing
       xlx.Quit ' se esiste l'applicazione excel la chiude
       Set xlx = Nothing
    
    End Function
    
    Public Function ifTableExists(tblName As String) As Boolean 'vedere se una tabella esiste
        If DCount("[Name]", "MSysObjects", "[Name] = '" & tblName & "'") = 1 Then
    
            ifTableExists = True
    
        End If
    
    End Function
    Public Function GetIndex(Tbf As DAO.TableDef) As String
       
       Dim Idx As Index
       For Each Idx In Tbf.Indexes
          On Error Resume Next
          If Idx.Primary Then GetIndex = Replace(Idx.Fields, "+", "")
       Next Idx
    End Function
    Public Function GetExcelColumn(FieldCount As Integer, WrkSht As Excel.Worksheet, FieldName As String) As String
       Dim i As Integer, ExecelApp As Object
    
    For i = 1 To FieldCount 'cerco dalla prima colonna della prima riga fino al numero di campi della tabella access se il nome campo access è uguale all'intestazione colonna di excel
       If WrkSht.Cells(1, i).Value = FieldName Then
          GetExcelColumn = (Left(Right(WrkSht.Cells(1, i).Address, Len(WrkSht.Cells(1, i).Address) - 1), InStr(WrkSht.Cells(1, i).Address, "$")))
          Exit For
       End If
    Next i
    
    End Function
    
Devi accedere o registrarti per scrivere nel forum
5 risposte