Moderatori: Anthony47, Flash30005
Sub ChColor()
Dim CheckArea As String, ColInd As Integer
'
CheckArea = "C3:N32"
TestCell = "C2"
'
ColIndex=2
Range(CheckArea).Interior.Color = Range(TestCell).Interior.Color
For Each Cell In Range(CheckArea)
If Application.WorksheetFunction.CountIf(Range(CheckArea), Cell.Value) > 1 _
And Cell.Interior.Color = Range(TestCell).Interior.Color Then
ColInd = ColInd + 1
Cell.Interior.ColorIndex = ColInd
LFor = Cell.Text
'==
With Range(CheckArea)
Set c = .Find(LFor, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
If c.Interior.Color = Range(TestCell).Interior.Color Then
c.Interior.ColorIndex = ColInd
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
'==
End If
Next Cell
End Sub
Public Conta, Conta1, RR, CC, RR2, CC2 As Integer, D1, D2 As Long
Sub Colora()
Range("C3:N32").Interior.ColorIndex = xlNone
For RR = 3 To 32
For CC = 3 To 14
Conta = 0
If Cells(RR, CC).Interior.ColorIndex <> xlNone Then GoTo salta
D1 = Cells(RR, CC).Value
For RR2 = 3 To 32
For CC2 = 3 To 14
If Cells(RR2, CC2).Value = "vuota" Then GoTo salta
If RR = RR2 And CC = CC2 Or Cells(RR2, CC2).Interior.ColorIndex <> xlNone Then GoTo salta
D2 = Cells(RR2, CC2).Value
If D1 = D2 Then Conta = Conta + 1
salta:
Next CC2
Next RR2
If Conta > 0 Then
If Conta = 1 Then Conta1 = Conta1 + 1
Call Evidenzia
End If
Next CC
Next RR
End Sub
Sub Evidenzia()
Dim Colore(30) As Integer
Colore(1) = 4
Colore(2) = 6
Colore(3) = 7
Colore(4) = 8
Colore(5) = 10
Colore(6) = 12
Colore(7) = 14
Colore(8) = 15
Colore(9) = 17
Colore(10) = 18
Colore(11) = 22
Colore(12) = 23
Colore(13) = 24
Colore(14) = 26
Colore(15) = 31
Colore(16) = 33
Colore(17) = 34
Colore(18) = 35
Colore(19) = 38
Colore(20) = 40
Colore(21) = 41
Colore(22) = 43
Colore(23) = 45
Colore(24) = 46
Colore(25) = 47
Colore(26) = 48
Colore(27) = 50
Colore(28) = 53
Colore(29) = 54
Colore(30) = 44
Conta1 = Conta1 Mod 30 + 1
For RE = 3 To 32
For CE = 3 To 14
If D1 = Cells(RE, CE).Value Then
If Conta = 1 Then
Cells(RE, CE).Interior.ColorIndex = Colore(Conta1)
Else
Cells(RE, CE).Interior.ColorIndex = Colore(Conta * 4)
End If
End If
Next CE
Next RE
End Sub
Conta1 = Conta1 Mod 30 + 1 '<<<< modifica
Conta1 = Conta1 Mod 8 + 1
Cells(RE, CE).Interior.ColorIndex = Colore(Conta * 4) '<<<< modifica
Cells(RE, CE).Interior.ColorIndex = Colore(Conta * 5)
ContaC = Conta1 + 8
Conta C = ContaC Mod 30 + 9
Cells(RE, CE).Interior.ColorIndex = Colore(Conta)
Flash30005 ha scritto:No non è così
colora di uguale colore quando ha i gruppi uguali es. se si ripetono tre volte avranno lo stesso colore come se si ripetono 4 volte (mi sembra che la tua richiesta fosse questa), mentre, avendo notato che si ripetono spesso date solo due volte ho fatto in maniera tale che si differenziassero come colore ma a volte può assumere un colore di un altro gruppo.
se segui la logica della macro ti accorgeresti di questo.
Potresti fare una modifica affinché non avrai mai i gruppi di due sole ripetizioni che si confondano con i gruppi di più ripetizioni modificando queste due righe di codice
- Codice: Seleziona tutto
Conta1 = Conta1 Mod 30 + 1 '<<<< modifica
così
- Codice: Seleziona tutto
Conta1 = Conta1 Mod 8 + 1
e quesa riga di codice
- Codice: Seleziona tutto
Cells(RE, CE).Interior.ColorIndex = Colore(Conta * 4) '<<<< modifica
così
- Codice: Seleziona tutto
Cells(RE, CE).Interior.ColorIndex = Colore(Conta * 5)
Spiego:
Conta1 conta solo quando hai una sola ripetizione e somma sempre 1 cambiando colore da 1 a 8 (dedichiamo solo 8 colori a questa combinazione
Conta invece è quando hai gruppi superiori a due date uguali, in questo caso moltiplica la variabile "Conta" per 5 quindi quando ci saranno date ripetute 3 volte avrai il colore 15 (del vettore Colore(15) = al colore 31)
con gruppi di 4 ripetizioni avrai 20 = colore 40 etc etc
Oppure (soluzione migliore, a mio avviso)
modifichi il Conta1 così
- Codice: Seleziona tutto
ContaC = Conta1 + 8
Conta C = ContaC Mod 30 + 9
e contemporaneamente
- Codice: Seleziona tutto
Cells(RE, CE).Interior.ColorIndex = Colore(Conta)
In qeusto ultimo caso, supponendo che Conta non superi 9 date uguali avrai combinazioni con gruppi da 3 date uguali a gruppi di 9 date uguali quindi il vettore Colore(n) varierà da 3 a 9
mentre il Conta1 sarà da 9 a 30 e non si accavalleranno con i gruppi con più date uguali
Prova e fai sapere
Ciao
Public Conta, Conta1, RR, CC, RR2, CC2 As Integer, D1, D2 As Long
Sub Colora()
Range("C3:N32").Interior.ColorIndex = xlNone
For RR = 3 To 32
For CC = 3 To 14
Conta = 0
If Cells(RR, CC).Interior.ColorIndex <> xlNone Then GoTo salta
D1 = Cells(RR, CC).Value
For RR2 = 3 To 32
For CC2 = 3 To 14
If Cells(RR2, CC2).Value = "vuota" Then GoTo salta
If RR = RR2 And CC = CC2 Or Cells(RR2, CC2).Interior.ColorIndex <> xlNone Then GoTo salta
D2 = Cells(RR2, CC2).Value
If D1 = D2 Then Conta = Conta + 1
salta:
Next CC2
Next RR2
If Conta > 0 Then
If Conta = 1 Then Conta1 = Conta1 + 1
Call Evidenzia
End If
Next CC
Next RR
End Sub
Sub Evidenzia()
Dim Colore(30) As Integer
Colore(1) = 4
Colore(2) = 6
Colore(3) = 7
Colore(4) = 8
Colore(5) = 10
Colore(6) = 12
Colore(7) = 14
Colore(8) = 15
Colore(9) = 17
Colore(10) = 18
Colore(11) = 22
Colore(12) = 23
Colore(13) = 24
Colore(14) = 26
Colore(15) = 31
Colore(16) = 33
Colore(17) = 34
Colore(18) = 35
Colore(19) = 38
Colore(20) = 40
Colore(21) = 41
Colore(22) = 43
Colore(23) = 45
Colore(24) = 46
Colore(25) = 47
Colore(26) = 48
Colore(27) = 50
Colore(28) = 53
Colore(29) = 54
Colore(30) = 44
ContaC = Conta1 + 8
ContaC = ContaC Mod 30 + 9
For RE = 3 To 32
For CE = 3 To 14
If D1 = Cells(RE, CE).Value Then
If Conta = 1 Then
Cells(RE, CE).Interior.ColorIndex = Colore(Conta)
Else
Cells(RE, CE).Interior.ColorIndex = Colore(Conta * 4)
End If
End If
Next CE
Next RE
End Sub
Anthony47 ha scritto:Se la mia macro va in errore e' perche' hai usato gia' tutti i "Color Index" disponibili che fino a xl2003 sono 56; ma se e' cosi' allora la l' idea di apprezzare a occhio quali date sono ripetute mi sembra una pretesa che il tuo occhio non apprezzera'.
Per i colori errati, intendi che date uguali hanno colori diversi, o che date diverse hanno colore uguale?
Ciao.
If Conta = 1 Then
Cells(RE, CE).Interior.ColorIndex = Colore(Conta) '<<<< da modificare
Else
Cells(RE, CE).Interior.ColorIndex = Colore(Conta * 4) '<<< questa io non l'ho prevista
If Conta = 1 Then
Cells(RE, CE).Interior.ColorIndex = Colore(ContaC) '<<<<< Codice corretto
Else
Cells(RE, CE).Interior.ColorIndex = Colore(Conta) '<<<< corretto come originale
Flash30005 ha scritto:Sorry!!!
La fretta...
La macro è stata studiata proprio per non avere le date che si ripetono una solo volta tutte dello stesso colore
e mi sembrva strano che venissero tutte celle verdi infatti...
Ho errato il codice di questa riga
- Codice: Seleziona tutto
If Conta = 1 Then
Cells(RE, CE).Interior.ColorIndex = Colore(Conta) '<<<< da modificare
Else
Cells(RE, CE).Interior.ColorIndex = Colore(Conta * 4) '<<< questa io non l'ho prevista
- Codice: Seleziona tutto
If Conta = 1 Then
Cells(RE, CE).Interior.ColorIndex = Colore(ContaC) '<<<<< Codice corretto
Else
Cells(RE, CE).Interior.ColorIndex = Colore(Conta) '<<<< corretto come originale
la variabile deve essere "ContaC" e non "Conta" altrimenti si colorano tutte di verde
Per quanto riguarda il cercare una specifica data e colorare le celle che hanno lo stesso valore non occorre fare la macro precedente e poi questo secondo step ma puoi fare direttamente questo step
oppure (ancora meglio, credo)
Avendo modificato la macro come postato qui avrai date (2 ripetizioni) diverse una dall'altra, a questo punto, si potrebbe fare in questa maniera:
inserisci la data in B5 (fondo neutro) e dopo la macro (secondo step) avrai la cella B5 dello stesso solore della data corrispondente nella tabella.
Cosa ne pensi?
ciao
Public Conta, Conta1, RR, CC, RR2, CC2 As Integer, D1, D2 As Long
Sub Colora()
Range("C3:N32").Interior.ColorIndex = xlNone
For RR = 3 To 32
For CC = 3 To 14
Conta = 0
If Cells(RR, CC).Interior.ColorIndex <> xlNone Then GoTo salta
D1 = Cells(RR, CC).Value
For RR2 = 3 To 32
For CC2 = 3 To 14
If Cells(RR2, CC2).Value = "vuota" Then GoTo salta
If RR = RR2 And CC = CC2 Or Cells(RR2, CC2).Interior.ColorIndex <> xlNone Then GoTo salta
D2 = Cells(RR2, CC2).Value
If D1 = D2 Then Conta = Conta + 1
salta:
Next CC2
Next RR2
If Conta > 0 Then
If Conta = 1 Then Conta1 = Conta1 + 1
Call Evidenzia
End If
Next CC
Next RR
End Sub
Sub Evidenzia()
Dim Colore(30) As Integer
Colore(1) = 4
Colore(2) = 6
Colore(3) = 7
Colore(4) = 8
Colore(5) = 10
Colore(6) = 12
Colore(7) = 14
Colore(8) = 15
Colore(9) = 17
Colore(10) = 18
Colore(11) = 22
Colore(12) = 23
Colore(13) = 24
Colore(14) = 26
Colore(15) = 31
Colore(16) = 33
Colore(17) = 34
Colore(18) = 35
Colore(19) = 38
Colore(20) = 40
Colore(21) = 41
Colore(22) = 43
Colore(23) = 45
Colore(24) = 46
Colore(25) = 47
Colore(26) = 48
Colore(27) = 50
Colore(28) = 53
Colore(29) = 54
Colore(30) = 44
ContaC = Conta1 + 8
ContaC = ContaC Mod 30 + 9
For RE = 3 To 32
For CE = 3 To 14
If D1 = Cells(RE, CE).Value Then
If Conta = 1 Then
Cells(RE, CE).Interior.ColorIndex = Colore(ContaC) '<<<<< Codice corretto
Else
Cells(RE, CE).Interior.ColorIndex = Colore(Conta) '<<<<< corretto come originale
End If
End If
Next CE
Next RE
End Sub
Public Conta, Conta1, RR, CC, RR2, CC2 As Integer, D1, D2 As Long
Sub Colora()
Conta1 = 0
Range("C3:N32").Interior.ColorIndex = xlNone
For RR = 3 To 32
For CC = 3 To 14
Conta = 0
If Cells(RR, CC).Interior.ColorIndex <> xlNone Then GoTo salta
D1 = Cells(RR, CC).Value
For RR2 = 3 To 32
For CC2 = 3 To 14
If Cells(RR2, CC2).Value = "vuota" Then GoTo salta
If RR = RR2 And CC = CC2 Or Cells(RR2, CC2).Interior.ColorIndex <> xlNone Then GoTo salta
D2 = Cells(RR2, CC2).Value
If D1 = D2 Then Conta = Conta + 1
salta:
Next CC2
Next RR2
If Conta > 0 Then
If Conta = 1 Then Conta1 = Conta1 + 1
Call Evidenzia
End If
Next CC
Next RR
End Sub
Sub Evidenzia()
Dim Colore(30) As Integer
Colore(1) = 4
Colore(2) = 6
Colore(3) = 7
Colore(4) = 8
Colore(5) = 10
Colore(6) = 12
Colore(7) = 14
Colore(8) = 15
Colore(9) = 17
Colore(10) = 18
Colore(11) = 22
Colore(12) = 23
Colore(13) = 24
Colore(14) = 26
Colore(15) = 31
Colore(16) = 33
Colore(17) = 34
Colore(18) = 35
Colore(19) = 38
Colore(20) = 40
Colore(21) = 41
Colore(22) = 43
Colore(23) = 45
Colore(24) = 46
Colore(25) = 47
Colore(26) = 48
Colore(27) = 50
Colore(28) = 53
Colore(29) = 54
Colore(30) = 44
ContaC = Conta1 + 8
ContaC = ContaC Mod 30
If ContaC = 0 Then ContaC = 9
For RE = 3 To 32
For CE = 3 To 14
If D1 = Cells(RE, CE).Value Then
If Conta = 1 Then
Cells(RE, CE).Interior.ColorIndex = Colore(ContaC)
Else
Cells(RE, CE).Interior.ColorIndex = Colore(Conta)
End If
End If
Next CE
Next RE
End Sub
Sub Trovadata()
DataB = Range("B35").Value
For RR = 3 To 32
For CC = 3 To 14
D1 = Cells(RR, CC).Value
If D1 = DataB Then
Cells(RR, CC).Copy
Range("B35").PasteSpecial Paste:=xlPasteFormats
GoTo esci
End If
Next CC
Next RR
MsgBox "Non ci sono date uguali", vbInformation
Range("B35").Interior.ColorIndex = xlNone
Range("B35").Font.ColorIndex = 3
esci:
Application.CutCopyMode = False
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$B$35" Then Exit Sub
Application.EnableEvents = False
Call Trovadata
Application.EnableEvents = True
End Sub
Sub intercetta()
a = Range("c50")
Cells.Find(What:=a, after:=ActiveCell, MatchCase:=True).Activate
ActiveCell.Interior.ColorIndex = 27
End Sub
Sub intercetta()
Range("c50").Interior.ColorIndex = 27
a = Range("c50")
With Worksheets("Foglio1").Range("C3:N32")
Set D = .Find(a, LookIn:=xlValues)
If Not D Is Nothing Then
firstDAddress = D.Address
Do
D.Interior.ColorIndex = 27
Set D = .FindNext(D)
On Error Resume Next
Loop While Not D Is Nothing And D.Address <> firstDAddress
On Error GoTo 0
End If
End With
End Sub
Flash30005 ha scritto:Prova questa macro
- Codice: Seleziona tutto
Sub intercetta()
Range("c50").Interior.ColorIndex = 27
a = Range("c50")
With Worksheets("Foglio1").Range("C3:N32")
Set D = .Find(a, LookIn:=xlValues)
If Not D Is Nothing Then
firstDAddress = D.Address
Do
D.Interior.ColorIndex = 27
Set D = .FindNext(D)
On Error Resume Next
Loop While Not D Is Nothing And D.Address <> firstDAddress
On Error GoTo 0
End If
End With
End Sub
Fai sapere
Ciao
Flash30005 ha scritto:Chiaramente il nome del foglio della macro deve corrispondere al nome del tuo foglio nel quale hai le date
e il range C53 e N85 corripondere al range delle date da colorare
la macro ti assicuro che funziona se impostata così,
altrimenti inviami il foglio con il quale potrò fare le dovute prove
ciao
Alessandro999 ha scritto:per quanto dici riguardo all' invio dei fogli , non so a che indirizzo li ricevi ?
Flash30005 ha scritto:Alessandro999 ha scritto:per quanto dici riguardo all' invio dei fogli , non so a che indirizzo li ricevi ?
Fai la stessa procedura scegliendo un Server Host poi il link (se non vuoi renderlo pubblico in un post del forum) lo invii in MP a me, inviando anche il link per cancellare il file dall'Host (Rapidshare lo fornisce).
ciao
Torna a Applicazioni Office Windows
Date CUP Web prenotabili su foglio excel Autore: aggittoriu |
Forum: Applicazioni Office Windows Risposte: 17 |
Conteggio date in giorni e contare le righe delle date Autore: ikwae |
Forum: Applicazioni Office Windows Risposte: 4 |
nome lavoratore in date specifiche (festivita) Autore: raimea |
Forum: Applicazioni Office Windows Risposte: 12 |
Visitano il forum: Nessuno e 66 ospiti