Messaggio di scadenza all'apertura di un file excel

Question

ho trovato questo ma non posso scaricare il file

Messaggio di scadenza all'apertura di un file excel - Microsoft Community

più che altro perchè ricevo un errore in questa parte della stringa

Call MsgBox(Prompt:="La cella " & Rng2.Address(0, 0) & " riporta " & sParola_da_Cercare, _

        Buttons:=vbInformation, \_ 

        Title:="REPORT")

Answer 1

Ciao Giorgio,

scusami in anticipo

ma se volessi fare questa operazione con un pulsante ?

ovviamente ho provato ed ovviamente ho un errore :-D

Per utilizzare un pulsante, incolla il seguente codice leggermente modificato in un modulo standard:

'========>>

Option Explicit

'-------->>

Public Sub Tester()

Dim SH As Worksheet 

Dim oTabella As ListObject 

Dim oListCol As ListColumn 

Dim Rng As Range, Rng2 As Range, rCell As Range 

Dim arrScaduto() As Variant 

Dim sMsg As String 

Dim iCtr As Long 

Const sFoglio As String = "Foglio1"                     '<<=== Modifica 

Const sTabella As String = "Tabella1"                   '<<=== Modifica 

Const iPrima\_Riga As Long = 5                           '<<=== Modifica 

Set SH = ThisWorkbook.Sheets(sFoglio) 

Set oTabella = SH.ListObjects(sTabella) 

Set oListCol = oTabella.ListColumns("Scadenza sub") 

Set Rng = oListCol.DataBodyRange 

For Each rCell In Rng.Cells 

    With rCell 

        If IsDate(.Value) Then 

            If .Value < Date Then 

                iCtr = iCtr + 1 

                ReDim Preserve arrScaduto(1 To iCtr) 

                arrScaduto(iCtr) = .Address(0, 0) & vbTab & .Offset(0, -10).Value 

            End If 

        End If 

    End With 

Next rCell 

If CBool(iCtr) Then 

    sMsg = "I seguenti record sono scaduti" & vbNewLine & vbNewLine & Join(arrScaduto, vbNewLine) 

End If 

Call MsgBox(Prompt:=sMsg, \_ 

    Buttons:=vbInformation, \_ 

    Title:="REPORT") 

End Sub

'<<========

Dopo aver assegnato questo codice al tuo pulsante, puoi facoltativamente eliminare il codice precedente. Se mantieni il codice esistente, l'avviso di scadenza apparirà anche quando apri il file.

===

Regards,

Norman

Answer 2

Ciao Giorgio,

Per la completezza, quando apro il mio file di prova, vedo il seguente avviso:

  [![](https://learn-attachment.microsoft.com/api/attachments/58934319-f1ee-4ded-b286-f506da3fb29f?platform=QnA"https://learn-attachment.microsoft.com/api/attachments/d5484314-60f5-48a7-91a0-1fe369d5211a?platform=QnA" rel="ugc nofollow">

Answer 3

Credo sia il problema dei filtri aziendali che non permettono file con macro

non possiamo nemmeno inviarli tramite posta..

Vedi sotto in fondo a questa risposta.

tornando a noi :-)

stavo provando a smanettare con il tuo file....top solo che vorrei far si che mi dia il nominativo del fornitore in scadenza

quindi dovrei modificare l'offset su - 3 ?

in più come vedi le colonne in scadenza in realtà sarebbero 2

ho provato ad inserirla io ma mi da errore

Ho modificato il mio file prova per emulare la configurazione dei dati visualizzata nella tua nuova immagine.

Con questa configurazione dei dati, il mio codice diventa:

'========>>

Option Explicit

'-------->>

Public Sub Workbook_Open()

Dim SH As Worksheet 

Dim oTabella As ListObject 

Dim oListCol As ListColumn 

Dim Rng As Range, Rng2 As Range, rCell As Range 

Dim arrScaduto() As Variant 

Dim sMsg As String 

Dim iCtr As Long 

Const sFoglio As String = **"Foglio1"                     '<<=== Modifica** 

Const sTabella As String = **"Tabella1"                   '<<=== Modifica** 

Const iPrima\_Riga As Long = **5                              '<<=== Modifica** 

Set SH = Me.Sheets(sFoglio) 

Set oTabella = SH.ListObjects(sTabella) 

Set oListCol = oTabella.ListColumns("Scadenza sub") 

Set Rng = oListCol.DataBodyRange 

For Each rCell In Rng.Cells 

    With rCell 

        If IsDate(.Value) Then 

            If .Value < Date Then 

                iCtr = iCtr + 1 

                ReDim Preserve arrScaduto(1 To iCtr) 

                arrScaduto(iCtr) = .Address(0, 0) & vbTab & .Offset(0, -10).Value 

            End If 

        End If 

    End With 

Next rCell 

If CBool(iCtr) Then 

    sMsg = "I seguenti record sono scaduti" & vbNewLine & vbNewLine & Join(arrScaduto, vbNewLine) 

End If 

Call MsgBox(Prompt:=sMsg, \_ 

    Buttons:=vbInformation, \_ 

    Title:="REPORT") 

End Sub

'<<========

Potresti scaricare il mio file di prova Giorgio20221117.xlsm

Date le restrizioni che incontri rispetto ai file abilitati per le macro, puoi in alternativa scaricare il mio file zip Giorgio20221117.zip che contiene il mio file di prova, privo di macro, e un file di testo che mostra il mio codice. Per evitare i problemi discussi in precedenza relativi all'editor del forum, ti suggerisco di copiare il codice dal mio file di testo nel file Excel xlsx compresso.

===

Regards,

Norman

Answer 4

Ciao Giorgio,

[...]

il file di prova purtroppo non riesco a scaricarlo

sempre per il motivo di cui sopra

[...]

Non capisco perché dovresti riscontrare problemi nel scaricare i miei file da OneDrive. Questa è un'operazione che viene eseguita più volte al giorno dai membri di questa Community.

Comunque, viste le tue difficoltà, ti invito a scaricare lo stesso file da DropBox:

**** https://www.dropbox.com/t/2mfom2f77LC4SJbv****

===

Regards,

Norman

Answer 5

Ciao Giorgio,

1- si esatto

2- una finestra che mi dice che ci sono dei fornitori con certificati scaduti sarebbe il top

3- si esatto

4- corretto

grazie infinite

Prova qualcosa del genere:

• Alt+F11 per aprire l'editor di VBA
• Ctrl+R per accedere alla finestra Project Explorer ('Gestione progetti')
• Fai doppio clic sul modulo ThisWorkbook (Questa_cartella_di_Lavoro) del file e incolla il seguente codice:

'========>>

Option Explicit

'-------->>

Public Sub Workbook_Open()

Dim SH As Worksheet 

Dim oTabella As ListObject 

Dim oListCol As ListColumn 

Dim Rng As Range, Rng2 As Range, rCell As Range 

Dim arrScaduto() As Variant 

Dim sMsg As String 

Dim iCtr As Long 

Const sFoglio As String = **"Foglio1"                     '<<=== Modifica** 

Const sTabella As String = **"Tabella1"                  '<<=== Modifica** 

Set SH = Me.Sheets(sFoglio) 

Set oTabella = SH.ListObjects(sTabella) 

Set oListCol = oTabella.ListColumns("Scadenza") 

Set Rng = oListCol.DataBodyRange 

For Each rCell In Rng.Cells 

    With rCell 

        If IsDate(.Value) Then 

            If .Value < Date Then 

                iCtr = iCtr + 1 

                ReDim Preserve arrScaduto(1 To iCtr) 

                arrScaduto(iCtr) = .Address(0, 0) & vbTab & .Offset(0, -2).Value 

            End If 

        End If 

    End With 

Next rCell 

If CBool(iCtr) Then 

    sMsg = "I seguenti record sono scaduti" & vbNewLine & vbNewLine & Join(arrScaduto, vbNewLine) 

End If 

Call MsgBox(Prompt:=sMsg, \_ 

    Buttons:=vbInformation, \_ 

    Title:="REPORT") 

End Sub

'<<========

• Alt+Q per chiudere l'editor di VBA e tornare a Excel
• Salva il file con l'estensione xlsm

Aprendo il mio file di prova (costruito con i dati del tipo indicato nella tua immagine), io ottengo il seguente avviso:

    [![](https://learn-attachment.microsoft.com/api/attachments/095db7f3-12fa-4e3e-9484-0ab94756155b?platform=QnA"https://1drv.ms/x/s!AmTW9HzZG8cqkzOHPl6s5QtClvCo?e=gg4hab" title="https://1drv.ms/x/s!AmTW9HzZG8cqkzOHPl6s5QtClvCo?e=gg4hab" rel="ugc nofollow">Giorgio20221116,xlsm

===
Regards,
Norman

Answer 6

Ciao Giorgio,

ho trovato questo ma non posso scaricare il file

Messaggio di scadenza all'apertura di un file excel - Microsoft Community

Io ho appena scaricato il file di prova senza alcun problema.

più che altro perchè ricevo un errore in questa parte della stringa

Call MsgBox(Prompt:="La cella " & Rng2.Address(0, 0) & " riporta " & sParola_da_Cercare, _

Buttons:=vbInformation, _

Title:="REPORT")

Facci vedere il messaggio di errore che riscontri e carica il tuo file problematica, privo di dati sensibili.

Per caricare il file su Microsoft OneDrive, vedi:

   Condividere file e cartelle di OneDrive

Per caricare il file su DropBox, vedi:

Come faccio a condividere file e cartelle in Dropbox?

===

Regards,

Norman