Εμφάνιση ενός μόνο μηνύματος
  #1  
Παλιά 30-10-21, 18:47
minas84 Ο χρήστης minas84 δεν είναι συνδεδεμένος
Όνομα: Μηνας
Έκδοση λογισμικού Office: Ms-Office 2013
Γλώσσα λογισμικού Office: Αγγλική
 
Εγγραφή: 17-06-2015
Μηνύματα: 15
Προεπιλογή Άθροισμα Βάση χρώματος άλλου κελιού

Kαλησπέρα έχω αυτό το test file που βάση ημερομηνίας μετράει πόσα κελιά απ' το κάθε χρώμα υπάρχουν "δίπλα" σε κάθε ημερομηνία.
Με τον παρακάτω κώδικα για κάθε ένα απ τα τρία χρώματα

Κώδικας:
Function DailyWin(MyColors As range, MyDates As range, Str As range) As Double
    Dim R  As Long: R = MyColors(1, 1).Row - MyDates(1, 1).Row
    Dim C  As Long: C = MyColors(1, 1).Column
    Dim Dt As range
    
    Application.Volatile
    With MyColors.Parent
        For Each Dt In MyDates
            If InStr(Dt.Value, Str.Value) Then
                If .Cells(Dt.Row + R, C).Interior.Color = RGB(198, 239, 206) Then
                    DailyWin = DailyWin + 1
                Else
                    DailyWin = DailyWin
                End If
            End If
        Next
    End With
End Function


Function DailyLost(MyColors As range, MyDates As range, Str As range) As Double
    Dim R  As Long: R = MyColors(1, 1).Row - MyDates(1, 1).Row
    Dim C  As Long: C = MyColors(1, 1).Column
    Dim Dt As range
    
    Application.Volatile
    With MyColors.Parent
        For Each Dt In MyDates
            If InStr(Dt.Value, Str.Value) Then
                If .Cells(Dt.Row + R, C).Interior.Color = RGB(255, 199, 206) Then
                    DailyLost = DailyLost + 1
                Else
                    DailyLost = DailyLost
                End If
            End If
        Next
    End With
End Function




Function DailyVoid(MyColors As range, MyDates As range, Str As range) As Double
    Dim R  As Long: R = MyColors(1, 1).Row - MyDates(1, 1).Row
    Dim C  As Long: C = MyColors(1, 1).Column
    Dim Dt As range
    
    Application.Volatile
    With MyColors.Parent
        For Each Dt In MyDates
            If InStr(Dt.Value, Str.Value) Then
                If .Cells(Dt.Row + R, C).Interior.Color = RGB(255, 235, 156) Then
                    DailyVoid = DailyVoid + 1
                Else
                    DailyVoid = DailyVoid
                End If
            End If
        Next
    End With
Θα ηθέλα να κάνω το ίδιο, αλλά αντί για ημερομηνιές να διαβάζει παλί χρώμα.
Συνημμένα Αρχεία
Τύπος Αρχείου: xlsm test.xlsm (16,7 KB, 2 εμφανίσεις)
Απάντηση με παράθεση