Ho avuto un po' di tempo per testare con un po' più di calma il codice e ho visto che c'era bisogno di qualche modifica soprattutto per gestire il caso in cui l'intervallo dei dati sia vuoto, sia composto da una sola riga o nel caso in cui, in presenza di
una voce nella prima colonna ma non vi siano valori in seconda colonna, o se presente in seconda colonna non vi sia valore in terza colonna.
Ho anche apportato una ulteriore modifica alla funzione di Norman perché in automatico ordini matrici ad una dimensione o a due dimensioni.
Ho anche fatto in modo che se il primo foglio attivo quando si apre il file è quello delle celle con le convalide vengano valorizzati i "riferimenti" lanciando la Sub ImpostaRiferimenti.
Ancora quando viene attivato il figlio con le celle con le convalide ora anche la prima cella viene cancellata (e viene eliminata la convalida) prima di reimpostare la convalida per la prima cella.
Questo il nuovo file di esempio: File esempio #2
Ripropongo il codice per intero.
Nel Modulo1
'----
Option Explicit
Public Const sNomeFoglioIntervallo As String = "Foglio1" '<= da personalizzare
Public Const sPrimaCellaIntervallo As String = "A3" '<= da personalizzare
Const sNomeFoglioConvalide As String = "Foglio2" '<= da personalizzare
Const sCellaConvalida1 As String = "A2" '<= da personalizzare
Const sCellaConvalida2 As String = "B2" '<= da personalizzare
Const sCellaConvalida3 As String = "C2" '<= da personalizzare
Public Wb As Workbook
Dim FoglioIntervallo As Worksheet
Dim FoglioConvalide As Worksheet
Dim rPrimaCellaIntervallo As Range
Dim rIntervalloDati As Range
Public rCellaConvalida1 As Range
Public rCellaConvalida2 As Range
Public rCellaConvalida3 As Range
Dim arrColonna1 As Variant
Dim arrColonna2 As Variant
Dim arrColonna3 As Variant
Sub ImpostaRiferimenti()
Set Wb = ThisWorkbook
With Wb
Set FoglioIntervallo = .Worksheets(sNomeFoglioIntervallo)
Set FoglioConvalide = .Worksheets(sNomeFoglioConvalide)
End With
Set rPrimaCellaIntervallo = FoglioIntervallo.Range(sPrimaCellaIntervallo)
Set rIntervalloDati = IntervalloDati_LrLc(rPrimaCellaIntervallo, False, False)
arrColonna1 = rIntervalloDati.Columns(1).Value
arrColonna2 = rIntervalloDati.Columns(2).Value
arrColonna3 = rIntervalloDati.Columns(3).Value
With FoglioConvalide
Set rCellaConvalida1 = .Range(sCellaConvalida1)
Set rCellaConvalida2 = .Range(sCellaConvalida2)
Set rCellaConvalida3 = .Range(sCellaConvalida3)
End With
End Sub
Sub ImpostaConvalida1()
Dim ArrConvalida As Variant
Dim sConvalida As String
If Wb Is Nothing Then Call ImpostaRiferimenti
If IsArray(arrColonna1) Then
ArrConvalida = SortedUniqueList(arrColonna1)
sConvalida = Join(ArrConvalida, ",")
Else
sConvalida = arrColonna1
End If
Call ImpostaConvalida(rCellaConvalida1, sConvalida)
End Sub
Sub ImpostaConvalida2()
Dim strConvalida1 As String
Dim iStr As String, iStr2 As String
Dim i As Long, cont As Long
Dim ArrConvalida() As Variant
Dim arrConvalidaUnique As Variant
Dim sConvalida As String
If Wb Is Nothing Then Call ImpostaRiferimenti
strConvalida1 = rCellaConvalida1.Value
If strConvalida1 <> vbNullString Then
If IsArray(arrColonna1) Then
For i = 1 To UBound(arrColonna1)
iStr = arrColonna1(i, 1)
If Not iStr = vbNullString Then
If iStr = strConvalida1 Then
iStr2 = arrColonna2(i, 1)
If Not iStr2 = vbNullString Then
cont = cont + 1
ReDim Preserve ArrConvalida(1 To cont)
ArrConvalida(cont) = iStr2
End If
End If
End If
Next i
If cont > 0 Then
arrConvalidaUnique = SortedUniqueList(ArrConvalida)
sConvalida = Join(arrConvalidaUnique, ",")
Call ImpostaConvalida(rCellaConvalida2, sConvalida)
End If
Else
sConvalida = arrColonna2
Call ImpostaConvalida(rCellaConvalida2, sConvalida)
End If
End If
End Sub
Sub ImpostaConvalida3()
Dim strConvalida1 As String, strConvalida2 As String
Dim iStr As String, iStr2 As String, iStr3 As String
Dim i As Long, j As Long, cont As Long
Dim ArrConvalida() As Variant
Dim arrConvalidaUnique As Variant
Dim sConvalida As String
If Wb Is Nothing Then Call ImpostaRiferimenti
strConvalida1 = rCellaConvalida1.Value
strConvalida2 = rCellaConvalida2.Value
If strConvalida2 <> vbNullString Then
If IsArray(arrColonna1) Then
For i = 1 To UBound(arrColonna1)
iStr = arrColonna1(i, 1)
If Not iStr = vbNullString Then
If iStr = strConvalida1 Then
iStr2 = arrColonna2(i, 1)
If Not iStr2 = vbNullString Then
If iStr2 = strConvalida2 Then
iStr3 = arrColonna3(i, 1)
If Not iStr3 = vbNullString Then
cont = cont + 1
ReDim Preserve ArrConvalida(1 To cont)
ArrConvalida(cont) = iStr3
End If
End If
End If
End If
End If
Next i
If cont > 0 Then
arrConvalidaUnique = SortedUniqueList(ArrConvalida)
sConvalida = Join(arrConvalidaUnique, ",")
Call ImpostaConvalida(rCellaConvalida3, sConvalida)
End If
Else
sConvalida = arrColonna3
Call ImpostaConvalida(rCellaConvalida3, sConvalida)
End If
End If
End Sub
Sub ImpostaConvalida(rngConvalida As Range, sConvalida As String)
With rngConvalida.Validation
.Delete
If sConvalida = vbNullString Then Exit Sub
.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:=sConvalida
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = "Errore"
.InputMessage = ""
.ErrorMessage = "Selezionare una voce dell'elenco a discesa!"
.ShowInput = True
.ShowError = True
End With
End Sub
'<--- funzione per impostare l'intervallo di celle da elaborare --->
Function IntervalloDati_LrLc(PrimaCellaDati As Range, _
Optional bRigaIntestazioni As Boolean = True, _
Optional bColonnaIntestazioni As Boolean = False, _
Optional sPassword As String = "", _
Optional bUserInterfaceOnly As Boolean = False) As Range
Dim Ws As Worksheet
Dim rng As Range
Dim bProtected As Boolean
Dim UltimaCellaDati As Range
Dim iUltimaRigaDati As Long, iUltimaColonnaDati As Long
Set Ws = PrimaCellaDati.Parent
If bRigaIntestazioni Then Set PrimaCellaDati = PrimaCellaDati.Offset(1, 0)
If bColonnaIntestazioni Then Set PrimaCellaDati = PrimaCellaDati.Offset(0, 1)
With Ws
bProtected = .ProtectContents
If bProtected Then .Unprotect Password:=sPassword
Set rng = .Cells
On Error Resume Next
iUltimaRigaDati = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
iUltimaColonnaDati = rng.Find(What:="*", _
After:=rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
With PrimaCellaDati
If iUltimaRigaDati < .Row Then iUltimaRigaDati = .Row
If iUltimaColonnaDati < .Column Then iUltimaColonnaDati = .Column
End With
Set UltimaCellaDati = .Cells(iUltimaRigaDati, iUltimaColonnaDati)
Set IntervalloDati_LrLc = .Range(PrimaCellaDati, UltimaCellaDati)
If bProtected Then .Protect Password:=sPassword, UserInterfaceOnly:=bUserInterfaceOnly
End With
End Function
Public Function SortedUniqueList(v As Variant) As Variant
'by Norman David Jones
Dim oSortedUniqueList As Object
Dim arrOut() As Variant
Dim sStr As String
Dim i As Long
Dim bool As Boolean
On Error Resume Next
bool = UBound(v, 2) > 0
On Error GoTo 0
Set oSortedUniqueList = CreateObject("System.Collections.SortedList")
With oSortedUniqueList
For i = LBound(v) To UBound(v)
If bool Then
sStr = v(i, 1)
Else
sStr = v(i)
End If
If Not sStr = vbNullString Then
If Not .ContainsKey(sStr) Then
.Add Key:=sStr, Value:=i
End If
End If
Next i
ReDim arrOut(1 To .Count)
For i = 0 To .Count - 1
arrOut(i + 1) = .GetKey(i)
Next i
End With
SortedUniqueList = arrOut
End Function
'----
Nel modulo di classe Foglio2
'----
Option Explicit
Private Sub Worksheet_Activate()
If Wb Is Nothing Then Call ImpostaRiferimenti
With rCellaConvalida1
.Validation.Delete
.ClearContents
End With
Call ImpostaRiferimenti
Call ImpostaConvalida1
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
On Error GoTo Errore
If Not Intersect(Target(1, 1), rCellaConvalida1) Is Nothing Then
With rCellaConvalida2
.Validation.Delete
.ClearContents
End With
With rCellaConvalida3
.Validation.Delete
.ClearContents
End With
Call ImpostaConvalida2
End If
If Not Intersect(Target(1, 1), rCellaConvalida2) Is Nothing Then
With rCellaConvalida3
.Validation.Delete
.ClearContents
End With
Call ImpostaConvalida3
End If
RiprendiErrore:
Application.EnableEvents = True
Exit Sub
Errore:
MsgBox "Si è verificato un errore!" & vbNewLine & _
"Errore numero: " & Err.Number & vbNewLine & _
Err.Description, vbCritical, "Errore VBA!"
Resume RiprendiErrore
End Sub
'----
![](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)
