![](data:image/svg+xml, %3Csvg xmlns='http://www.w3.org/2000/svg' height='64' class='font-weight-bold' style='font: 600 30.11764705882353px "SegoeUI", Arial' width='64'%3E%3Ccircle fill='hsl(128, 8%, 22%)' cx='32' cy='32' r='32' /%3E%3Ctext x='50%25' y='55%25' dominant-baseline='middle' text-anchor='middle' fill='%23FFF' %3EA%3C/text%3E%3C/svg%3E)
Microsoft 365 e Office | Access | Per la casa | Windows
Una famiglia di sistemi di gestione per database relazionali di Microsoft progettati per semplificare l'uso.
ciao Nicola,
spero di avere letto tutto ed ho visto il post sulla sezione di xls .
qui mi sembra si discutesse del filtro che hai trattato con Mimmo:
secondo me potrebbe esseree il caso di sfruttare il filtro applicato alla form per passarlo al metodo queryTables per popolare un file di excel, anziché creare un altra query.
Da access direi di estrarre tutte le colonne che ti servono senza manipolare post il file di xls creato.
lo stesso per l'aggiunta della funzione somma delle ore.
Il filtro diventa così :
Private Sub cmdFilter_Click()
Dim strFilter As String
strFilter = ""
Const concat As String = " and "
If Nz(Me.txtPozzoTipo) <> "" Then strFilter = strFilter & "PozzoTipo=" & Me.txtPozzoTipo & concat
If Nz(Me.txtDal) <> "" Then strFilter = strFilter & "del between " & CLng(Me.txtDal) & concat & CLng(Me.txtAl) & concat
If Nz(Me.cboAnno) <> "" Then strFilter = strFilter & "year(del)='" & Me.cboAnno & "'" & concat
If Nz(Me.cboCognomeNome) <> "" Then strFilter = strFilter & Me.cboCognomeNome & concat
If Len(strFilter) > 0 Then
strFilter = Left$(strFilter, Len(strFilter) - Len(concat))
Me.Filter = strFilter
Me.FilterOn = True
Else
Me.Filter = ""
Me.FilterOn = False
End If
End Sub
il codice di esportazione su xls così :
Private Sub cmdEsportaExcel_Click()
Dim strSql As String
strSql = "SELECT TblPozzo.Tipo, TblPozzo.Descrizione, tblTurniIrrigazione.Del, CDate(CDbl([tempo])) as tempoOra, tblSoci.CognomeNome" & _
" FROM tblSoci INNER JOIN (TblPozzo INNER JOIN tblTurniIrrigazione ON TblPozzo.Tipo = tblTurniIrrigazione.ID_Socio) ON tblSoci.ID_Socio = tblTurniIrrigazione.ID_Socio "
If Len(Me.Filter) <> 0 Then
strSql = strSql & " where " & Me.Filter
End If
' Debug.Print strSql
export2XLs2 strSql
End Sub
e questo il modulo per esportare su xls :
Option Compare Database
Option Explicit
Public Sub export2XLs2(ByVal strSql As String)
Dim xlApp As Object
Dim wbk As Object 'as Workbook
Dim wsh As Object 'as Worksheet
Dim LastRow As Long
Dim dbp As Access.CurrentProject
Dim bool As Boolean
Dim xlQry As Object
Const cstrXlClass = "Excel.Application"
Const cstrFullName = "c:\prova\nicola.xlsx"
If fileExists(cstrFullName) Then Kill cstrFullName
Const cstrCnn = "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0" _
& ";Data Source=" & cstrFullName _
& ";Mode=Read;"
Dim blnNotRunning As Boolean
Dim strCnn As String
With Application
Set dbp = .CurrentProject
End With
strCnn = Replace(cstrCnn, cstrFullName, dbp.FullName)
blnNotRunning = getXlSinstance(xlApp, False, cstrXlClass)
With xlApp
If blnNotRunning Then
' .Visible = True
.ScreenUpdating = False
End If
End With
If fileExists(cstrFullName) Then
Set wbk = xlApp.Workbooks.Open(cstrFullName)
Else
Set wbk = xlApp.Workbooks.Add
End If
Set wsh = wbk.Worksheets.Item(1)
LastRow = wsh.range("A1").end(-4121).Row ' xlDown
If LastRow = wsh.cells(wsh.cells.Rows.Count, 1).end(-4121).Row Then
LastRow = 1
bool = Not bool
End If
With wsh
Set xlQry = .QueryTables.Add(Connection:=strCnn _
, Destination:=.range("A" & LastRow))
End With
With xlQry
.CommandType = 2 ' 2 è la costante per xlCmdSql
.CommandText = strSql
.AdjustColumnWidth = bool
.FieldNames = bool
.Refresh
.Delete
End With
With xlApp
.displayAlerts = False
.ScreenUpdating = True
.Calculation = -4105 'xlAutomatic
LastRow = LastWbkRow(wsh)
With wsh
.cells(2 + LastRow, 4).Value = "=SUM(d2:d" & LTrim(Str(LastRow)) & ")"
.cells(2 + LastRow, 4).numberFormat = "hh:mm:ss"
.range("d2:d" & LTrim(Str(LastRow))).numberFormat = "hh:mm:ss"
End With
wbk.SaveAs FileName:=cstrFullName
wbk.Close SaveChanges:=True _
, FileName:=cstrFullName
.displayAlerts = True
End With
MsgBox "Salvato ed esportato", vbInformation, "Avviso"
exitErrorHandler:
Set wsh = Nothing
Set wbk = Nothing
xlApp.Quit
Set xlApp = Nothing
Exit Sub
errorHandler:
With Err
MsgBox "ERR#" & CStr(.Number) _
& vbNewLine & .Description _
, vbOKOnly Or vbCritical
End With
Resume exitErrorHandler
End Sub
' funzione LastWbkRow Norman David Jones
Public Function LastWbkRow(SH As Object, Optional Rng As Object, _
Optional minRow As Long = 1)
If Rng Is Nothing Then
Set Rng = SH.cells
End If
On Error Resume Next
LastWbkRow = Rng.Find(What:="*", After:=Rng.cells(1), _
Lookat:=2, _
LookIn:=-4123, _
SearchOrder:=1, _
SearchDirection:=2, _
MatchCase:=0).Row
On Error GoTo 0
If LastWbkRow < minRow Then
LastWbkRow = minRow
End If
End Function
Private Function getXlSinstance(xlApp As Object _
, isXlsRunning As Boolean _
, strClass As String) As Boolean
Err.Clear
If isXlsRunning Then
On Error Resume Next
Set xlApp = GetObject(, strClass)
End If
If xlApp Is Nothing Then
Set xlApp = CreateObject(strClass)
End If
If Err <> 0 Then
MsgBox "Qualcosa non va controlla questo l'errore:" & Err.Description, _
vbCritical, "Attenzione!!!"
getXlSinstance = False
Else
getXlSinstance = True
End If
End Function
Private Function fileExists(strFullPath As String) As Boolean
On Error Resume Next
fileExists = ((GetAttr(strFullPath) And vbDirectory) = 0)
End Function
Private Function folderExists(strPath As String) As Boolean
On Error Resume Next
folderExists = ((GetAttr(strPath) And vbDirectory) = vbDirectory)
End Function
post esportazione controlla la cartella c:\prova trovi il file con l'esportazione filtrata il file si chiama nicola.xlsx
questo il tuo database modificato.
Facci sapere.
Ciao,Sandro.