Macro Excel per l'aggiornamento della convalida dati

Question

Buongiorno. In riferimento a una macro Excel creata da David Jones Norman, volevo chiedere se la stessa può essere applicata a più fogli di lavoro della stessa cartella. Grazie'=========>>

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

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

Answer 1

Ciao Lino70**,**

Buongiorno. In riferimento a una macro Excel creata da David Jones Norman, volevo chiedere se la stessa può essere applicata a più fogli di lavoro della stessa cartella. Grazie'=========>>

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

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

Ponendo che il foglio sorgente sella convalida dati sia il foglio Foglio2, nel modulo di codice di quel foglio incolla il seguente codice:

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

Option Explicit

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

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim SH As Worksheet, srcSH As Worksheet

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

    Dim rCell As Range

    Dim arrFogli As Variant

    Dim sCiboOld As String, sCiboNew As String

    Dim arrCibiOld As Variant, arrCibiNew As Variant

    Dim Res As Variant

    Const sFoglio_Sorgente As String = "Foglio2"             '<<=== Modifica

    Set srcSH = ThisWorkbook.Worksheets(sFoglio_Sorgente)

    Set rCibi = srcSH.Range("Cibi")

    Set rSrc = Intersect(rCibi, Target)

    If Not rSrc Is Nothing Then

        arrCibiNew = rCibi.Value

        On Error GoTo XIT

        With Application

            .EnableEvents = False

            .Undo

        End With

        arrCibiOld = rCibi.Value

        rCibi = arrCibiNew

        For Each SH In ThisWorkbook.Worksheets

            On Error Resume Next

            Set rDest = SH.Cells.SpecialCells(xlCellTypeAllValidation)

            On Error GoTo 0

            If Not rDest Is Nothing Then

                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

        Next SH

    End If

XIT:

    Application.EnableEvents = True

End Sub

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

Potresti scaricare il mio file di prova Lino20200508.xlsm:

===

Regards,

Norman

Answer 2

Ciao Pasquale,

Grazie mille Norman per la tua grandissima competenza e disponibilità, funziona perfettamente.

Mi fa piacere che tu abbia risolto il problema e ti ringrazio per il cortese riscontro.

Per chiudere questo thread, vorrei chiederti gentilmente di contrassegnare la mia risposta come Risposta preferita. 

===

Regards,

Norman 

Answer 3

Grazie mille Norman per la tua grandissima competenza e disponibilità, funziona perfettamente.

Cordiali saluti, Pasquale