Excel VBA: copia dati da DB in foglio Excel con modifica formato dati

Question

Salve

dovrei realizzare uno foglio excel che genera una lista di dati pescandoli da un db access, terminato l'aggiornamento chiede se si desidera esportare il foglio dati sul computer.

Qui c'è un file di esempio:

http://1drv.ms/1JuR51s

in cui vorrei aggiungere queste opzioni:

• i dati memorizzati nel DB sono in formato testo, io vorrei che quelli relativi agli anni siano riportati in excel in formato numero
• aggiungere a tutta la tabella compilata i bordi
• se non ci sono dati (per esempio impostando il 2014 la tabella resta vuota) un messaggio tipo "Nessun Dato"
• chiedere al termine dell'aggiornamento se si vuole salvare la tabella sul proprio PC.

In particolare mi interesserebbe capire come fare l'ultimo punto (chiedere se si desidera salvare la tabella).

Grazie

Nixio

Answer 1

ciao Mauro,

per la late binding Dao io sarei arrivato fin qua....spero sia buona e che magari possa essere utile a qualcuno...magari al nostro OP, in primo luogo :-).

Ho inserito un paio due funzioni, controllo esistenza oggetto, e versione dao ( quest'ultima modificata da un tuo collega MVP )presa da qui :http://www.jpsoftwaretech.com/reference-latest-version-of-dbengine/.

Ovviamente il controllo dell'esistenza oggetto da implementare un po' meglio...nel senso se l'oggetto non esiste esco dalla routine, ed invocato prima di dichiarare le variabili ect, ect.

Mi piacerebbe proseguire permettendo all'utente di visualizzare  la/e tabella/e e/o la/e query/queries da importare 1/2 user form, rendendo il tutto maggiormente flessibile....ma non sono assolutamente in grado...magari più avanti quando le mie competenze saranno maggiori.

Grazie per avermi spronato un pochetto nel cercare migliorie... :-)

Ciao alla prossima, Sandro.

Option Explicit

Private Const strPathDb As String = "C:\Users\Sandro\Desktop\toXls\totXls1.accdb" '<------personalizza

'

Sub importFromAccess()

On Error GoTo errorHandler

Dim dbs        As Object 'as dao.database

Dim dbE        As Object 'as dbegine(0)(0)

Dim rst        As Object 'As DAO.Recordset

Dim strSql     As String

Set dbE = GetDBEngine

Set dbs = dbE.OpenDatabase(strPathDb)

'If MyObject("query1", 1, dbs) Then MsgBox "esisto"  ' togliendo il commento verifo la presenza dell'oggetto

strSql = "select * from clienti"       '<------personalizza

Set rst = dbs.OpenRecordset(strSql, 2) ' dbOpenDynaset

With rst

    .MoveLast

    .MoveFirst

End With

' se il recordset è vuoto si genere l'errore 3021 gestito dalla gestione errori errorHandler

' e si distruggono le variabili oggetto create

' altrimenti se il recordset non è vuoto si prosegue.

With Application

        .ScreenUpdating = False

        .Calculation = xlManual

End With

Dim wbk        As Object 'as Workbook

Dim wsh        As Object 'as Worksheet

Dim xlQry      As Object 'As Excel.QueryTable

Dim lastRow    As Long

Dim lastColumn As Long

Dim i          As Integer

Set wbk = ThisWorkbook

With wbk

    .Worksheets.Add Before:=Worksheets(Worksheets.Count)

    Application.DisplayAlerts = False

     For i = .Worksheets.Count To 2 Step -1

        .Worksheets.Item(i).Delete

     Next

     Application.DisplayAlerts = True

End With

Set wsh = wbk.Worksheets(1)

wsh.Name = "EstrazioneDaAccess"

With wsh

     Set xlQry = .QueryTables.Add(Connection:=rst _

                                     , Destination:=.Range("A1"))

     With xlQry

            .Refresh BackgroundQuery:=False

     End With

End With

lastRow = wsh.Range("A1").End(xlDown).Row

lastColumn = Cells(1, Cells.Columns.Count).End(xlToLeft).Column

With wsh.Range(Cells(1, 1), Cells(lastRow, lastColumn)).Borders

     .LineStyle = xlContinuous

     .ColorIndex = xlAutomatic

End With

If MsgBox("vuoi salvare il file di excel appena crato?", vbInformation + vbOKCancel, "avviso") = vbOK Then

       wbk.SaveAs Filename:=wbk.Path & "" & Replace(strSql, "*", "")

    End If

With Application

        .ScreenUpdating = True

        .Calculation = xlAutomatic

End With

exitErrorHandler:

    Set wsh = Nothing

    Set wbk = Nothing

    Set xlQry = Nothing

    rst.Close

    Set rst = Nothing

    dbs.Close

    Set dbs = Nothing

    Set dbE = Nothing

    Exit Sub

errorHandler:

    With Err

       If Err.Number = 3021 Then

          MsgBox "nessun records da impostare, tabella vuota", vbCritical

       Else

            MsgBox "ERR#" & CStr(.Number) _

                & vbNewLine & .Description _

                , vbOKOnly Or vbCritical

       End If

     End With

     Resume exitErrorHandler

End Sub

Public Function GetDBEngine() As Object

  Dim versions() As String

  Dim i As Long

  ' put versions from newest to oldest into array

  versions = Split("120,36,35", ",")

  ' loop through array and try to set obj reference

  For i = LBound(versions) To UBound(versions)

    On Error Resume Next

    Set GetDBEngine = CreateObject("DAO.DBEngine." & versions(i))

    If Not GetDBEngine Is Nothing Then ' found it!

     'Debug.Print versions(i)

      Exit For

    End If

  Next i

End Function

Public Function MyObject(ByVal strname As String _

                         , ByVal ObjectType As Integer _

                         , ByVal dbs As Object) As Boolean

    On Error GoTo MyObject_err

    Dim obj As Object

    MyObject = True

    Select Case ObjectType

        Case 0

            Set obj = dbs.TableDefs(strname)

        Case 1

            Set obj = dbs.QueryDefs(strname)

    End Select

MyObject_Exit:

    On Error GoTo 0

    Set obj = Nothing

    Exit Function

MyObject_err:

    MyObject = False

    Resume MyObject_Exit

End Function

Answer 2

ciao Nixio,

ho apportato le modifiche di cui al post precedente, mi sembra che sia ok.

in grassetto le modifiche.

HTH.

Ciao, Sandro.

Sub importFromAccess()

Dim rst        As ADODB.Recordset

Dim connDB     As ADODB.Connection

Dim wbk        As Workbook

Dim strSql     As String

Dim strDB      As String

Dim strConn    As String

Dim bool       As Boolean

Set wbk = ThisWorkbook

Set rst = New ADODB.Recordset

Set connDB = New ADODB.Connection

strDB = wbk.Path & "\totXls1.accdb"

strSql = "select count(*) from ordini"

connDB.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strDB

rst.Open strSql, connDB

Set rst = connDB.Execute(strSql)

If rst.Fields(0) = 0 Then

    MsgBox "nessun record da importare", vbCritical, "avviso"

    bool = Not bool

    GoTo exitImportFromAccess

End If

Dim wsh        As Worksheet

Dim xlQry      As Excel.QueryTable

Dim lastRow    As Long

Dim lastColumn As Long

Dim i          As Integer

strConn = "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0" _

           & ";Data Source=" & strDB _

           & ";Mode=Read;"

With wbk

.Worksheets.Add Before:=Worksheets(Worksheets.Count)

Application.DisplayAlerts = False

For i = .Worksheets.Count To 2 Step -1

.Worksheets.Item(i).Delete

Next

Application.DisplayAlerts = True

End With

Set wsh = wbk.Worksheets(1)

wsh.Name = "EstrazioneDaAccess"

strSql = "select * from ordini"

With wsh

     Set xlQry = .QueryTables.Add(Connection:=strConn _

                                     , Destination:=.Range("A1"))

     With xlQry

            .CommandText = strSql

            .Refresh BackgroundQuery:=False

    End With

End With

lastRow = wsh.Range("A1").End(xlDown).Row

lastColumn = Cells(1, Cells.Columns.Count).End(xlToLeft).Column

wsh.Range(Cells(1, 1), Cells(lastRow, lastColumn)).Select

Selection.Borders(xlDiagonalDown).LineStyle = xlNone

Selection.Borders(xlDiagonalUp).LineStyle = xlNone

With Selection.Borders(xlEdgeLeft)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlEdgeTop)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlEdgeBottom)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlEdgeRight)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlInsideVertical)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlInsideHorizontal)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

ext_sub:

    If Not bool Then

        If MsgBox("vuoi salvare il file di excel appena crato?", vbInformation + vbOKCancel, "avviso") = vbOK Then

            wbk.SaveAs Filename:=wbk.Path & "" & Replace(strSql, "*", "")

        End If

    End If

    Exit Sub

exitImportFromAccess:

    Set rst = Nothing

    Set wsh = Nothing

    Set wbk = Nothing

    Set xlQry = Nothing

    GoTo ext_sub

End Sub

Answer 3

ciao Nixio,

capito :-), modificando questa riga di codice, ovviamente con il path corretto, dovrebbe funzionare tutto...

strDB = wbk.Path & "\totXls1.accdb"

ciao, Sandro.

Answer 4

Grazie per la risposta, il problema è che non posso intervenire direttamente sul DB access ma solo tramite un excel che poi utilizzano piu utenti

Answer 5

ciao Nixio,

secondo me ti conviene esportare da access, è più semplice...

prova nel seguente modo...il db su cui ho eseguito il test è il northWind di Access, tabella ordini.

Il risultato c'è, per certo migliorabile, Excel io non lo uso, mi ci sono cimentato per sfida personale.

Per il salvataggio del file sarebbe meglio impostare un controllo nella cartella di destino per verificare l'esistenza di un file con lo stesso nome....

Prova e facci sapere!

ciao, Sandro.

Option Explicit

Sub importFromAccess()

Dim rst        As ADODB.Recordset

Dim connDB     As ADODB.Connection

Dim wbk        As Workbook

Dim strSql     As String

Dim strDB      As String

Dim strConn    As String

Dim bool       As Boolean

Set wbk = ThisWorkbook

Set rst = New ADODB.Recordset

Set connDB = New ADODB.Connection

strDB = wbk.Path & "\totXls1.accdb"

strSql = "select count(*) from ordini"

connDB.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strDB

rst.Open strSql, connDB

Set rst = connDB.Execute(strSql)

If rst.Fields(0) = 0 Then

    MsgBox "nessun record da importare", vbCritical, "avviso"

    bool = Not bool

    GoTo exitImportFromAccess

End If

Dim wsh        As Worksheet

Dim xlQry      As Excel.QueryTable

Dim lastRow    As Long

Dim lastColumn As Long

strConn = "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0" _

           & ";Data Source=" & strDB _

           & ";Mode=Read;"

Set wsh = wbk.Worksheets(1)

strSql = "select * from ordini"

With wsh

     Set xlQry = .QueryTables.Add(Connection:=strConn _

                                     , Destination:=.Range("A1"))

     With xlQry

            .CommandText = strSql

            .Refresh BackgroundQuery:=False

    End With

End With

lastRow = wsh.Range("A1").End(xlDown).Row

lastColumn = Cells(1, Cells.Columns.Count).End(xlToLeft).Column

wsh.Range(Cells(1, 1), Cells(lastRow, lastColumn)).Select

Selection.Borders(xlDiagonalDown).LineStyle = xlNone

Selection.Borders(xlDiagonalUp).LineStyle = xlNone

With Selection.Borders(xlEdgeLeft)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlEdgeTop)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlEdgeBottom)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlEdgeRight)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlInsideVertical)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlInsideHorizontal)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

ext_sub:

    If Not bool Then

        If MsgBox("vuoi salvare il file di excel appena creato?", vbInformation + vbYesNo, "avviso") = vbYes Then

            wbk.SaveAs Filename:=wbk.Path & "" & Replace(strSql, "*", "")

        End If

    End If

    Exit Sub

exitImportFromAccess:

    Set rst = Nothing

    Set wsh = Nothing

    Set wbk = Nothing

    Set xlQry = Nothing

    GoTo ext_sub

End Sub