VBA colorare celle in base a riferimento matrice

[Bert0]

ciao a tutti...

il buon Norman mi ha creato questo codice che colora una matrice in base a
dei riferimenti presi da un'altra matrice...

il tutto funziona a meraviglia solo che, per l'uso che devo farne io, ci
sarebbe una piccola modifica da fare...

i colori delle celle vengono dati all'interno del codice memtre i vorrei che
venissero presi da excel:

questo è la parte del codice originale:

Set Rng = Me.Range("O13:O113") '<<=== da CAMBIARE

arrColori = VBA.Array(15, 34, 36, 37, 38, 39, 44, _
19, 24, 20, 43, 33, _
28, 16, 12, 47, 48, 40, _
42, 45, 41) '<<=== da CAMBIARE


e dovrebbe diventare una cosa simile
Set Rng = Me.Range("O13:O113") '<<=== da CAMBIARE

arrColori = VBA.Array("F21", "F22", ecc ecc ecc

cioè al posto del numero dovrei far riferimento ad una cella...

spero di essermi spiegato bene e di non disturbare troppo...

Garzie Roberto

P.s. sotto il codice completo

'=============>>
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range
Dim Rng2 As Range
Dim Rng3 As Range
Dim rCell As Range
Dim arrColori As Variant
Dim arrParole As Variant
Dim res As Variant
Dim i As Long

Set Rng = Me.Range("O13:O113") '<<=== da CAMBIARE

arrColori = VBA.Array(15, 34, 36, 37, 38, 39, 44, _
19, 24, 20, 43, 33, _
28, 16, 12, 47, 48, 40, _
42, 45, 41) '<<=== da CAMBIARE

arrParole = Application.Transpose(Me.Range("G21:G41").Value)

On Error Resume Next
Set Rng2 = Intersect(Rng.Precedents, Target)
On Error GoTo 0

If Not Rng2 Is Nothing Then
Set Rng3 = Intersect(Rng2.Dependents, Rng)
End If

If Not Rng3 Is Nothing Then
For Each rCell In Rng3.Cells
With rCell
.Interior.ColorIndex = xlNone
For i = LBound(arrParole) To UBound(arrParole)
If InStr(1, .Value, arrParole(i), _
vbTextCompare) > 0 Then
res = Application.Match _
(.Value, arrParole(i), 0)
.Interior.ColorIndex = arrColori(i)
Exit For
Else
End If
Next i
End With
Next rCell
End If
End Sub
'<<=============

[Norman Jones]

Ciao Roberto,

'----------------
il buon Norman mi ha creato questo codice che colora una matrice in base a
dei riferimenti presi da un'altra matrice...

il tutto funziona a meraviglia solo che, per l'uso che devo farne io, ci
sarebbe una piccola modifica da fare...

i colori delle celle vengono dati all'interno del codice memtre i vorrei che
venissero presi da excel:

questo è la parte del codice originale:

Set Rng = Me.Range("O13:O113") '<<=== da CAMBIARE

arrColori = VBA.Array(15, 34, 36, 37, 38, 39, 44, _
19, 24, 20, 43, 33, _
28, 16, 12, 47, 48, 40, _
42, 45, 41) '<<=== da CAMBIARE


e dovrebbe diventare una cosa simile
Set Rng = Me.Range("O13:O113") '<<=== da CAMBIARE

arrColori = VBA.Array("F21", "F22", ecc ecc ecc

cioè al posto del numero dovrei far riferimento ad una cella...
'----------------

Inserisci i numeri dei colori nell'intervallo H2:H21
e prova qualcosa del genere:

'=============>>
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range
Dim Rng2 As Range
Dim Rng3 As Range
Dim RngColori As Range
Dim rCell As Range
Dim arrColori As Variant
Dim arrParole As Variant
Dim res As Variant
Dim i As Long

Set Rng = Me.Range("A13:A113") '<<=== da CAMBIARE
Set RngColori = Me.Range("H2:H21") '<<=== da CAMBIARE

arrColori = Application.Transpose(RngColori.Value)
arrParole = Application.Transpose(Me.Range("G21:G41").Value)

On Error Resume Next
Set Rng2 = Intersect(Rng.Precedents, Target)
On Error GoTo 0

If Not Rng2 Is Nothing Then
Set Rng3 = Intersect(Rng2.Dependents, Rng)
End If

If Not Rng3 Is Nothing Then
For Each rCell In Rng3.Cells
With rCell
.Interior.ColorIndex = xlNone
For i = LBound(arrParole) To UBound(arrParole)
If InStr(1, .Value, arrParole(i), _
vbTextCompare) > 0 Then
res = Application.Match _
(.Value, arrParole(i), 0)
.Interior.ColorIndex = arrColori(i)
Exit For
Else
End If
Next i
End With
Next rCell
End If
End Sub
'<<=============



---
Regards,
Norman
Microsoft Excel MVP

[Bert0]

ciao Norman e grazie...

funziona perfettamente...
mentre io:
potevo provarci all'infinito... e purtroppo senza risultato
io avevo potatao per un'altra soluzione

thanks roberto

Post by Norman Jones
Ciao Roberto,
'----------------
il buon Norman mi ha creato questo codice che colora una matrice in base a
dei riferimenti presi da un'altra matrice...
il tutto funziona a meraviglia solo che, per l'uso che devo farne io, ci
sarebbe una piccola modifica da fare...
i colori delle celle vengono dati all'interno del codice memtre i vorrei che
Set Rng = Me.Range("O13:O113") '<<=== da CAMBIARE
arrColori = VBA.Array(15, 34, 36, 37, 38, 39, 44, _
19, 24, 20, 43, 33, _
28, 16, 12, 47, 48, 40, _
42, 45, 41) '<<=== da CAMBIARE
e dovrebbe diventare una cosa simile
Set Rng = Me.Range("O13:O113") '<<=== da CAMBIARE
arrColori = VBA.Array("F21", "F22", ecc ecc ecc
cioè al posto del numero dovrei far riferimento ad una cella...
'----------------
Inserisci i numeri dei colori nell'intervallo H2:H21
'=============>>
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range
Dim Rng2 As Range
Dim Rng3 As Range
Dim RngColori As Range
Dim rCell As Range
Dim arrColori As Variant
Dim arrParole As Variant
Dim res As Variant
Dim i As Long
Set Rng = Me.Range("A13:A113") '<<=== da CAMBIARE
Set RngColori = Me.Range("H2:H21") '<<=== da CAMBIARE
arrColori = Application.Transpose(RngColori.Value)
arrParole = Application.Transpose(Me.Range("G21:G41").Value)
On Error Resume Next
Set Rng2 = Intersect(Rng.Precedents, Target)
On Error GoTo 0
If Not Rng2 Is Nothing Then
Set Rng3 = Intersect(Rng2.Dependents, Rng)
End If
If Not Rng3 Is Nothing Then
For Each rCell In Rng3.Cells
With rCell
.Interior.ColorIndex = xlNone
For i = LBound(arrParole) To UBound(arrParole)
If InStr(1, .Value, arrParole(i), _
vbTextCompare) > 0 Then
res = Application.Match _
(.Value, arrParole(i), 0)
.Interior.ColorIndex = arrColori(i)
Exit For
Else
End If
Next i
End With
Next rCell
End If
End Sub
'<<=============
---
Regards,
Norman
Microsoft Excel MVP