refresh automatico DATE modificate dall'elenco convalida dati

Question

Salve,

premettendo che non sono pratico di VBA script e che il mio problema è una variante molto molto simile a questo:

https://answers.microsoft.com/it-it/msoffice/forum/all/aiuto-aggiornamento-automatico-dei-dati-una-volta/f30be9cd-031f-4e3e-909b-6f7eb6066d6e

per il quale il moderatore Norman David Jones ha scritto, nei commenti/risposte al post, un codice VBA risolutivo e funzionante (lo riporto in basso).

Il mio caso è quasi identico ma nelle celle ho delle DATE (ad es. 30/08/2022) invece che dei semplici testi, per cui il codice VBA di Norman non funziona più. Ho provato a modificarlo ma, per mia ignoranza, non riesco a renderlo funzionante.

Vi chiedo gentilmente se potete rispondere col codice VBA modificato adatto al mio caso.

Vi ringrazio anticipatamente e mi scuso per le lacune tecniche.

Norman ha scritto:

Prova qualcosa del genere:

Fai clic dx sulla linguetta del foglio Foglio2

Seleziona l'opzione Visualizza Codice dal menu contestuale risultante

Incolla il seguente codice: 

'=========>>

Option Explicit

'--------->>

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim destSH As Worksheet

    Dim rCibi As Range, rSrc As Range, rDest As Range

    Dim rCell As Range

    Dim sCiboOld As String, sCiboNew As String

    Dim arrCibiOld As Variant, arrCibiNew As Variant

    Dim Res As Variant

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

    Const sColonnaConvalidaDCati As String = "D"     '<<=== Modifica

    Set destSH = ThisWorkbook.Sheets(sFoglioDestinazione)

    Set rCibi = Me.Range("Cibi")

    Set rSrc = Intersect(rCibi, Target)

    If Not rSrc Is Nothing Then

        Set rDest = destSH.Columns(sColonnaConvalidaDCati)

        arrCibiNew = rCibi.Value

        On Error GoTo XIT

        With Application

            .EnableEvents = False

            .Undo

        End With

        arrCibiOld = rCibi.Value

        rCibi = arrCibiNew

        For Each rCell In rSrc.Cells

            sCiboNew = rCell.Value

            Res = Application.Match(sCiboNew, arrCibiNew, 0)

            sCiboOld = arrCibiOld(Res, 1)

            rDest.Replace What:=sCiboOld, _

                          Replacement:=sCiboNew, _

                          LookAt:=xlWhole, _

                          SearchOrder:=xlByRows, _

                          MatchCase:=False

        Next rCell

    End If

XIT:

    Application.EnableEvents = True

End Sub

'<<=========

Alt+Q per chiudere l'editor di VBA e tornare a Excel.

Salva il file con l'estensione xlsm.

Potresti scaricare il mio file di prova Villuccio2180605.xlsm Qui il link al file

Answer 1

Ciao epicureo.aq,

premettendo che non sono pratico di VBA script e che il mio problema è una variante molto molto simile a questo:

https://answers.microsoft.com/it-it/msoffice/forum/all/aiuto-aggiornamento-automatico-dei-dati-una-volta/f30be9cd-031f-4e3e-909b-6f7eb6066d6e

per il quale il moderatore Norman David Jones ha scritto, nei commenti/risposte al post, un codice VBA risolutivo e funzionante (lo riporto in basso).

Il mio caso è quasi identico ma nelle celle ho delle DATE (ad es. 30/08/2022) invece che dei semplici testi, per cui il codice VBA di Norman non funziona più. Ho provato a modificarlo ma, per mia ignoranza, non riesco a renderlo funzionante.

Vi chiedo gentilmente se potete rispondere col codice VBA modificato adatto al mio caso.

Vi ringrazio anticipatamente e mi scuso per le lacune tecniche.

Norman ha scritto:

Prova qualcosa del genere:

Fai clic dx sulla linguetta del foglio Foglio2

Seleziona l'opzione Visualizza Codice dal menu contestuale risultante

Incolla il seguente codice: 

'=========>>



Option Explicit



'--------->>



Private Sub Worksheet_Change(ByVal Target As Range)



    Dim destSH As Worksheet



    Dim rCibi As Range, rSrc As Range, rDest As Range



    Dim rCell As Range



    Dim sCiboOld As String, sCiboNew As String



    Dim arrCibiOld As Variant, arrCibiNew As Variant



    Dim Res As Variant



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



    Const sColonnaConvalidaDCati As String = "D"     '<<=== Modifica



    Set destSH = ThisWorkbook.Sheets(sFoglioDestinazione)



    Set rCibi = Me.Range("Cibi")



    Set rSrc = Intersect(rCibi, Target)



    If Not rSrc Is Nothing Then



        Set rDest = destSH.Columns(sColonnaConvalidaDCati)



        arrCibiNew = rCibi.Value



        On Error GoTo XIT



        With Application



            .EnableEvents = False



            .Undo



        End With



        arrCibiOld = rCibi.Value



        rCibi = arrCibiNew



        For Each rCell In rSrc.Cells



            sCiboNew = rCell.Value



            Res = Application.Match(sCiboNew, arrCibiNew, 0)



            sCiboOld = arrCibiOld(Res, 1)



            rDest.Replace What:=sCiboOld, _



                          Replacement:=sCiboNew, _



                          LookAt:=xlWhole, _



                          SearchOrder:=xlByRows, _



                          MatchCase:=False



        Next rCell



    End If



XIT:



    Application.EnableEvents = True



End Sub



'<<=========

Alt+Q per chiudere l'editor di VBA e tornare a Excel.

Salva il file con l'estensione xlsm.

Potresti scaricare il mio file di prova Villuccio2180605.xlsm Qui il link al file

Per gestire le date, prova la seguente leggera modifica del mio vecchio codice:

'=========>>

Option Explicit

'--------->>

Private Sub Worksheet_Change(ByVal Target As Range)

Dim destSH As Worksheet 

Dim rCibi As Range, rSrc As Range, rDest As Range 

Dim rCell As Range 

Dim sCiboOld As String, sCiboNew As String 

Dim arrCibiOld As Variant, arrCibiNew As Variant 

Dim Res As Variant 

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

Const sColonnaConvalidaDCati As String = **"D"        '<<=== Modifica** 

Set destSH = ThisWorkbook.Sheets(sFoglioDestinazione) 

Set rCibi = Me.Range("Cibi") 

Set rSrc = Intersect(rCibi, Target) 

If Not rSrc Is Nothing Then 

    Set rDest = destSH.Columns(sColonnaConvalidaDCati) 

    arrCibiNew = rCibi.Value 

    On Error GoTo XIT 

    With Application 

        .EnableEvents = False 

        .Undo 

    End With 

    arrCibiOld = rCibi.Value 

    rCibi = arrCibiNew 

    For Each rCell In rSrc.Cells 

        sCiboNew = rCell.Value 

        Res = Application.Match(sCiboNew, arrCibiNew, 0) 

        sCiboOld = arrCibiOld(Res, 1) 

        rDest.Replace What:=**CDate(**sCiboOld**)**, \_ 

                      Replacement:=**CDate(**sCiboNew**)**, \_ 

                      LookAt:=xlWhole, \_ 

                      SearchOrder:=xlByRows, \_ 

                      MatchCase:=False 

    Next rCell 

End If 

XIT:

Application.EnableEvents = True 

End Sub

'<<=========

Potresti scaricare il mio file di prova Epicureo20220830.xlsm

Se dovessi ancora avere un problema, ti chiederei gentilmente di caricare il tuo file problematico.

===

Regards,

Norman

Answer 2

Ciao epicureo.aq,

fatto ;-)

Grazie ancora!

Ti ringrazio per il cortese riscontro.

Alla prossima.

===

Regards,

Norman

Answer 3

fatto ;-)

Grazie ancora!

Answer 4

Ciao epicureo.aq,

Grazie mille Norman,

funziona perfettamente!

Bene, mi fa piacere!

Per chiudere questo thread, ti chiederei gentilmente di contrassegnare la mia Risposta precedente.

===

Regards,

Norman

Answer 5

Grazie mille Norman,

funziona perfettamente!