Function Color Collection

Cesco80

Utente abituale
13 Luglio 2019
473
28
39
Verona Prov.
Office 2019
31
Spunto dalla recente richiesta,condivido questa raccolta di Function trovate in rete che permettono di :

TrovaColoreCella
TrovaColoreCarattere
ContaCellePerColore
SommaCellePerColore
ContaCellePerColoreCarattere
SommaCellePerColoreCarattere
CartellaContaCellePerColore

Esempio: =CartellaContaCellePerColore(A1) "Conterà tutte le celle del colore di A1"
Esempio: =CartellaSommaCellePerColore(A1) "Sommerà tutte le celle del colore di A1"
Visual Basic:
Function TrovaColoreCella(xlIntervallo As Range)
    Dim indRiga, indColonna As Long
    Dim arRisultati()
 
    Application.Volatile
 
    If xlIntervallo Is Nothing Then
        Set xlIntervallo = Application.ThisCell
    End If
 
    If xlIntervallo.Count > 1 Then
      ReDim arRisultati(1 To xlIntervallo.Rows.Count, 1 To xlIntervallo.Columns.Count)
       For indRiga = 1 To xlIntervallo.Rows.Count
         For indColonna = 1 To xlIntervallo.Columns.Count
           arRisultati(indRiga, indColonna) = xlIntervallo(indRiga, indColonna).Interior.Color
         Next
       Next
     TrovaColoreCella = arRisultati
    Else
     TrovaColoreCella = xlIntervallo.Interior.Color
    End If
End Function
 
Function TrovaColoreCarattere(xlIntervallo As Range)
    Dim indRiga, indColonna As Long
    Dim arRisultati()
 
    Application.Volatile
 
    If xlIntervallo Is Nothing Then
        Set xlIntervallo = Application.ThisCell
    End If
 
    If xlIntervallo.Count > 1 Then
      ReDim arRisultati(1 To xlIntervallo.Rows.Count, 1 To xlIntervallo.Columns.Count)
       For indRiga = 1 To xlIntervallo.Rows.Count
         For indColonna = 1 To xlIntervallo.Columns.Count
           arRisultati(indRiga, indColonna) = xlIntervallo(indRiga, indColonna).Font.Color
         Next
       Next
     TrovaColoreCarattere = arRisultati
    Else
     TrovaColoreCarattere = xlIntervallo.Font.Color
    End If
 
End Function
 
Function ContaCellePerColore(rData As Range, cellRefColor As Range) As Long
    Dim indRefColor As Long
    Dim cellaCorrente As Range
    Dim cntRes As Long
 
    Application.Volatile
    cntRes = 0
    indRefColor = cellRefColor.Cells(1, 1).Interior.Color
    For Each cellaCorrente In rData
        If indRefColor = cellaCorrente.Interior.Color Then
            cntRes = cntRes + 1
        End If
    Next cellaCorrente
 
    ContaCellePerColore = cntRes
End Function
 
Function SommaCellePerColore(rData As Range, cellRefColor As Range)
    Dim indRefColor As Long
    Dim cellaCorrente As Range
    Dim sumRes
 
    Application.Volatile
    sumRes = 0
    indRefColor = cellRefColor.Cells(1, 1).Interior.Color
    For Each cellaCorrente In rData
        If indRefColor = cellaCorrente.Interior.Color Then
            sumRes = WorksheetFunction.Sum(cellaCorrente, sumRes)
        End If
    Next cellaCorrente
 
    SommaCellePerColore = sumRes
End Function
 
Function ContaCellePerColoreCarattere(rData As Range, cellRefColor As Range) As Long
    Dim indRefColor As Long
    Dim cellaCorrente As Range
    Dim cntRes As Long
 
    Application.Volatile
    cntRes = 0
    indRefColor = cellRefColor.Cells(1, 1).Font.Color
    For Each cellaCorrente In rData
        If indRefColor = cellaCorrente.Font.Color Then
            cntRes = cntRes + 1
        End If
    Next cellaCorrente
 
    ContaCellePerColoreCarattere = cntRes
End Function
 
Function SommaCellePerColoreCarattere(rData As Range, cellRefColor As Range)
    Dim indRefColor As Long
    Dim cellaCorrente As Range
    Dim sumRes
 
    Application.Volatile
    sumRes = 0
    indRefColor = cellRefColor.Cells(1, 1).Font.Color
    For Each cellaCorrente In rData
        If indRefColor = cellaCorrente.Font.Color Then
            sumRes = WorksheetFunction.Sum(cellaCorrente, sumRes)
        End If
    Next cellaCorrente
 
    SommaCellePerColoreCarattere = sumRes
End Function
Function CartellaContaCellePerColore(cellRefColor As Range)
    Dim vWbkRes
    Dim foglioCorrente As Worksheet
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    vWbkRes = 0
    For Each foglioCorrente In Worksheets
       foglioCorrente.Activate
       vWbkRes = vWbkRes + ContaCellePerColore(foglioCorrente.UsedRange, cellRefColor)
    Next
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
 
    CartellaContaCellePerColore = vWbkRes
End Function
 
Function CartellaSommaCellePerColore(cellRefColor As Range)
    Dim vWbkRes
    Dim foglioCorrente As Worksheet
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    vWbkRes = 0
    For Each foglioCorrente In Worksheets
       foglioCorrente.Activate
       vWbkRes = vWbkRes + SommaCellePerColore(foglioCorrente.UsedRange, cellRefColor)
    Next
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
 
    CartellaSommaCellePerColore = vWbkRes
End Function
 

Sostieni ForumExcel

Aiutaci a sostenere le spese e a mantenere online la community attraverso una libera donazione!