Moderatori: Anthony47, Flash30005
=(CONTA.SE(B$8:B8;B8)<2)+(CONTA.SE(F$8:F8;F8)<2)
=$M8=2
Sub highl()
Dim LastB As Long, I As Long, CIB As Boolean, CIF As Boolean
'
LastB = Cells(Rows.Count, "B").End(xlUp).Row
Range("B8").Resize(LastB - 7).Interior.ColorIndex = xlNone
Range("B8").Resize(LastB - 7).Interior.ColorIndex = xlNone
For I = 8 To LastB
CIB = Application.WorksheetFunction.CountIf(Range("B8").Resize(I - 7), Cells(I, "B")) < 2
CIF = Application.WorksheetFunction.CountIf(Range("F8").Resize(I - 7), Cells(I, "F")) < 2
If CIB And CIF Then
Cells(I, "B").Interior.Color = RGB(255, 255, 0)
Cells(I, "F").Interior.Color = RGB(255, 255, 0)
End If
Next I
End Sub
Sub Colora()
Dim LastB As Long, I As Long
LastB = Cells(Rows.Count, "B").End(xlUp).Row
Range("B8").Resize(LastB - 7).Interior.ColorIndex = xlNone
Range("F8").Resize(LastB - 7).Interior.ColorIndex = xlNone
For I = 8 To LastB
CIF2 = Application.WorksheetFunction.CountIf(Range(Cells(7, 6), Cells(I - 1, 6)), Cells(I, 6))
CIB2 = Application.WorksheetFunction.CountIf(Range(Cells(7, 2), Cells(I - 1, 2)), Cells(I, 2))
If CIF2 = 0 And CIB2 = 0 Then
Cells(I, "B").Interior.Color = RGB(255, 255, 0)
Cells(I, "F").Interior.Color = RGB(255, 255, 0)
GoTo SaltaCol
End If
If CIB2 = 0 And CIF2 > 0 Then
For NN = 8 To I - 1
If Cells(NN, 6) = Cells(I, 6) And Cells(NN, 6).Interior.Color = RGB(255, 255, 0) Then GoTo SaltaCol
Next NN
Cells(I, "B").Interior.Color = RGB(255, 255, 0)
Cells(I, "F").Interior.Color = RGB(255, 255, 0)
End If
SaltaCol:
Next I
End Sub
Sub Colora()
Dim LastB As Long, I As Long
LastB = Cells(Rows.Count, "B").End(xlUp).Row
Range("B8").Resize(LastB - 7).Interior.ColorIndex = xlNone
Range("F8").Resize(LastB - 7).Interior.ColorIndex = xlNone
For I = 8 To LastB
CIF2 = Application.WorksheetFunction.CountIf(Range(Cells(7, 6), Cells(I - 1, 6)), Cells(I, 6))
CIB2 = Application.WorksheetFunction.CountIf(Range(Cells(7, 2), Cells(I - 1, 2)), Cells(I, 2))
If CIF2 = 0 And CIB2 = 0 Then
Cells(I, "B").Interior.Color = RGB(255, 255, 0)
Cells(I, "F").Interior.Color = RGB(255, 255, 0)
GoTo SaltaCol
Else
For NN = 8 To I - 1
If Cells(NN, 6) = Cells(I, 6) And Cells(NN, 6).Interior.Color = RGB(255, 255, 0) Then GoTo SaltaCol
If Cells(NN, 2) = Cells(I, 2) And Cells(NN, 2).Interior.Color = RGB(255, 255, 0) Then GoTo SaltaCol
Next NN
End If
Cells(I, "B").Interior.Color = RGB(255, 255, 0)
Cells(I, "F").Interior.Color = RGB(255, 255, 0)
SaltaCol:
Next I
End Sub
Sub Colora2()
' 16.6
Dim LastB As Long, I As Long, myArrB(), myArrF(), myColB, myColF, CI6 As String, CI2 As Long, myRGB As Long
'
LastB = Cells(Rows.Count, "B").End(xlUp).Row
Range("B8").Resize(LastB - 7).Interior.ColorIndex = xlNone
Range("F8").Resize(LastB - 7).Interior.ColorIndex = xlNone
myTim = Timer
ReDim myArrB(8 To LastB)
ReDim myArrF(8 To LastB)
'
myColB = Range("B1").Resize(LastB, 1).Value '*3
myColF = Range("F1").Resize(LastB, 1).Value
myRGB = RGB(255, 255, 0) '*4
For I = 8 To LastB
CIF2 = Application.WorksheetFunction.CountIf(Range(Cells(7, 6), Cells(I - 1, 6)), Cells(I, 6))
CIB2 = Application.WorksheetFunction.CountIf(Range(Cells(7, 2), Cells(I - 1, 2)), Cells(I, 2))
If CIF2 = 0 And CIB2 = 0 Then
myArrB(I) = myRGB
myArrF(I) = myRGB
GoTo SaltaCol
Else
CI6 = Cells(I, 6): CI2 = Cells(I, 2) '*2
For NN = 8 To I - 1
If myColF(NN, 1) = CI6 And myArrF(NN) = myRGB Then GoTo SaltaCol
If myColB(NN, 1) = CI2 And myArrB(NN) = myRGB Then GoTo SaltaCol
Next NN
End If
myArrB(I) = myRGB
myArrF(I) = myRGB
SaltaCol:
Next I
For I = 8 To LastB
If myArrB(I) > 0 Then Cells(I, "B").Interior.Color = myArrB(I)
If myArrF(I) > 0 Then Cells(I, "F").Interior.Color = myArrF(I)
Next I
MsgBox ("Completato in " & Timer - myTim)
End Sub
Torna a Applicazioni Office Windows
Macro che scatta quando cambia dato in un altro file Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 14 |
Problema con macro copia e rinomina file Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 2 |
Macro che ricerca combinazioni che danno un valore Autore: kar64 |
Forum: Applicazioni Office Windows Risposte: 10 |
Macro che indica la riga prima della cella attiva Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 19 |
Visitano il forum: Nessuno e 92 ospiti