تغییر رنگ سلول بعد از تاریخ معین

من قبلا یه ماکرو برای اینکار نوشتم که با زدن یه دکمه کلیه تاریخ هایی شمسی از یه تعداد روز به بعد رنگی میشه فقط نمیدونم چطور فایلش رو برات ارسال کنم:

Sub calc()
    On Error Resume Next
    cell_charcter = InputBox("Enter Cell Caracter:", "Enter Cell Name", "A")
    
    Range(cell_charcter + ":" + cell_charcter).Interior.ColorIndex = 2
    num_all = InputBox("Enter Num of cells:", "Enter Cell Num", "100")
    Days_num = InputBox("Enter Num of Days:", "Enter Days Num", "30")
    For i = 1 To Val(num_all)
        address_call = Trim(cell_charcter + Trim(Str(i)))
        If Range(address_call).Text <> "" Then
            date_s = Range(address_call).Text
            Dim sss As Date
            sss = s2m(date_s)
            num_of_day = Date - sss
            If Val(num_of_day) > Val(Days_num) Then
                Range(address_call).Select
                Selection.Interior.ColorIndex = 3
            Else
                Range(address_call).Select
                Selection.Interior.ColorIndex = 2
            End If
            num_of_day = ""
            Range("A1").Select
        End If
    Next i
End Sub

Private Function Ceil(Number As Single) As Long
    Ceil = -Sgn(Number) * Int(-Abs(Number))
End Function

'
' Determine Julian day from Persian date
'
Function persian_jdn(iYear, iMonth, iDay)
    Const PERSIAN_EPOCH = 1948321 ' The JDN of 1 Farvardin 1
    Dim epbase As Long
    Dim epyear As Long
    Dim mdays As Long
    If iYear >= 0 Then
        epbase = iYear - 474
    Else
        epbase = iYear - 473
    End If
    epyear = 474 + (epbase Mod 2820)
    If iMonth <= 7 Then
        mdays = (CLng(iMonth) - 1) * 31
    Else
        mdays = (CLng(iMonth) - 1) * 30 + 6
    End If
    persian_jdn = CLng(iDay) _
            + mdays _
            + Fix(((epyear * 682) - 110) / 2816) _
            + (epyear - 1) * 365 _
            + Fix(epbase / 2820) * 1029983 _
            + (PERSIAN_EPOCH - 1)
End Function
'
Sub jdn_persian(jdn, iYear, iMonth, iDay)
    Dim depoch
    Dim cycle
    Dim cyear
    Dim ycycle
    Dim aux1, aux2
    Dim yday
    depoch = jdn - persian_jdn(475, 1, 1)
    cycle = Fix(depoch / 1029983)
    cyear = depoch Mod 1029983
    If cyear = 1029982 Then
        ycycle = 2820
    Else
        aux1 = Fix(cyear / 366)
        aux2 = cyear Mod 366
        ycycle = Int(((2134 * aux1) + (2816 * aux2) + 2815) / 1028522) + aux1 + 1
    End If
    iYear = ycycle + (2820 * cycle) + 474
    If iYear <= 0 Then
        iYear = iYear - 1
    End If
    yday = (jdn - persian_jdn(iYear, 1, 1)) + 1
    If yday <= 186 Then
        iMonth = Ceil(yday / 31)
    Else
        iMonth = Ceil((yday - 6) / 30)
    End If
    iDay = (jdn - persian_jdn(iYear, iMonth, 1)) + 1
End Sub
Function civil_jdn(ByVal iYear, ByVal iMonth, ByVal iDay)
    Dim lYear
    Dim lMonth
    Dim lDay
    Dim calendatType
    calendarType = Gregorian
    If calendarType = Gregorian And ((iYear > 1582) _
        Or ((iYear = 1582) And (iMonth > 10)) _
        Or ((iYear = 1582) And (iMonth = 10) And (iDay > 14))) Then

        lYear = CLng(iYear)
        lMonth = CLng(iMonth)
        lDay = CLng(iDay)
        civil_jdn = ((1461 * (lYear + 4800 + ((lMonth - 14) \ 12))) \ 4) _
                + ((367 * (lMonth - 2 - 12 * (((lMonth - 14) \ 12)))) \ 12) _
                - ((3 * (((lYear + 4900 + ((lMonth - 14) \ 12)) \ 100))) \ 4) _
                + lDay - 32075
    Else
        civil_jdn = julian_jdn(iYear, iMonth, iDay)
    End If

End Function
Sub jdn_julian(jdn, iYear, iMonth, iDay)
    Dim L As Long
    Dim K As Long
    Dim n As Long
    Dim i As Long
    Dim j As Long

    j = jdn + 1402
    K = ((j - 1) \ 1461)
    L = j - 1461 * K
    n = ((L - 1) \ 365) - (L \ 1461)
    i = L - 365 * n + 30
    j = ((80 * i) \ 2447)
    iDay = i - ((2447 * j) \ 80)
    i = (j \ 11)
    iMonth = j + 2 - 12 * i
    iYear = 4 * K + n + i - 4716

End Sub
Function julian_jdn(iYear, iMonth, iDay) As Long
   
    julian_jdn = 367 * lYear - _
            ((7 * (lYear + 5001 + ((lMonth - 9) \ 7))) \ 4) _
            + ((275 * lMonth) \ 9) + lDay + 1729777

End Function
Sub jdn_civil(jdn, iYear, iMonth, iDay)

    Dim L
    Dim K
    Dim n
    Dim i
    Dim j

    If (jdn > 2299160) Then
        L = jdn + 68569
        n = ((4 * L) \ 146097)
        L = L - ((146097 * n + 3) \ 4)
        i = ((4000 * (L + 1)) \ 1461001)
        L = L - ((1461 * i) \ 4) + 31
        j = ((80 * L) \ 2447)
        iDay = L - ((2447 * j) \ 80)
        L = (j \ 11)
        iMonth = j + 2 - 12 * L
        iYear = 100 * (n - 49) + i + L
    Else
        Call jdn_julian(jdn, iYear, iMonth, iDay)
    End If

End Sub

'Function m2s(myDate)
'    iDay = Day(myDate)
'    iMonth = Month(myDate)
'    iYear = Year(myDate)
'    jdn = civil_jdn(iYear, iMonth, iDay)
'    Call jdn_persian(jdn, iYear, iMonth, iDay)
'    m2s = iYear & "/" & iMonth & "/" & iDay
'End Function

Function s2m(myDate)
   Dim iYear, iMonth, iDay
    For i = 1 To Len(myDate)
        st = Mid(myDate, i, 1)
        
        If (st = "/" Or st = "-" Or st = "." Or st = "\") And x <> 1 Then
                x = 1
                If i = 3 Then s = "13" & s
        Else
                If (st = "/" Or st = "-" Or st = "." Or st = "\") And x = 1 Then
                    x = 2
                    If i = 5 Or i = 7 Then s = Left(s, Len(s) - 1) & "0" & Right(s, 1)
                Else
                    s = s & st
                End If
       End If
     Next
        If Len(s) = 7 Then s = Left(s, 6) & "0" & Right(s, 1)
    myDate = s
    iYear = Mid(myDate, 1, 4)
    iMonth = Mid(myDate, 5, 2)
    iDay = Mid(myDate, 7, 2)
    If (iDay > 30 And iMonth > 6) Or iDay > 31 Or iMonth > 12 Then s2m = "Error": Exit Function
    
    If (iDay = 30 And iMonth = 12) Then
    iYear1 = iYear + 1
    iMonth1 = 1
    iDay1 = 1
    jdn1 = persian_jdn(iYear1, iMonth1, iDay1)
    jdn = persian_jdn(iYear, iMonth, iDay)
    If jdn1 = jdn Then s2m = "Error": Exit Function
    End If
    
    jdn = persian_jdn(iYear, iMonth, iDay)
    Call jdn_civil(jdn, iYear, iMonth, iDay)
    s2m = iYear & "/" & iMonth & "/" & iDay
End Function

Function m2s(myDate, Optional Format = 0)
    iDay = Day(myDate)
    iMonth = Month(myDate)
    iYear = Year(myDate)
    iWeekday = Weekday(myDate)
            
    jdn = civil_jdn(iYear, iMonth, iDay)
    Call jdn_persian(jdn, iYear, iMonth, iDay)
    
    Select Case iWeekday
    Case 1
        Rooz = ChrW(1740) & ChrW(1705) & ChrW(1588) & ChrW(1606) & ChrW(1576) & ChrW(1607)
    Case 2
        Rooz = ChrW(1583) & ChrW(1608) & ChrW(1588) & ChrW(1606) & ChrW(1576) & ChrW(1607)
    Case 3
        Rooz = ChrW(1587) & ChrW(1607) & ChrW(8204) & ChrW(1588) & ChrW(1606) & ChrW(1576) & ChrW(1607)
    Case 4
        Rooz = ChrW(1670) & ChrW(1607) & ChrW(1575) & ChrW(1585) & ChrW(1588) & ChrW(1606) & ChrW(1576) & ChrW(1607)
    Case 5
        Rooz = ChrW(1662) & ChrW(1606) & ChrW(1580) & ChrW(8204) & ChrW(1588) & ChrW(1606) & ChrW(1576) & ChrW(1607)
    Case 6
        Rooz = ChrW(1580) & ChrW(1605) & ChrW(1593) & ChrW(1607)
    Case 7
        Rooz = ChrW(1588) & ChrW(1606) & ChrW(1576) & ChrW(1607)
    End Select
    
   
   Select Case iMonth
    
    Case 1
        mah = ChrW(1601) & ChrW(1585) & ChrW(1608) & ChrW(1585) & ChrW(1583) & ChrW(1740) & ChrW(1606)
    Case 2
        mah = ChrW(1575) & ChrW(1585) & ChrW(1583) & ChrW(1740) & ChrW(1576) & ChrW(1607) & ChrW(1588) & ChrW(1578)
    Case 3
        mah = ChrW(1582) & ChrW(1585) & ChrW(1583) & ChrW(1575) & ChrW(1583)
    Case 4
        mah = ChrW(1578) & ChrW(1740) & ChrW(1585)
    Case 5
        mah = ChrW(1605) & ChrW(1585) & ChrW(1583) & ChrW(1575) & ChrW(1583)
    Case 6
        mah = ChrW(1588) & ChrW(1607) & ChrW(1585) & ChrW(1740) & ChrW(1608) & ChrW(1585)
    Case 7
        mah = ChrW(1605) & ChrW(1607) & ChrW(1585)
    Case 8
        mah = ChrW(1570) & ChrW(1576) & ChrW(1575) & ChrW(1606)
    Case 9
        mah = ChrW(1570) & ChrW(1584) & ChrW(1585)
    Case 10
        mah = ChrW(1583) & ChrW(1740)
    Case 11
        mah = ChrW(1576) & ChrW(1607) & ChrW(1605) & ChrW(1606)
    Case 12
        mah = ChrW(1575) & ChrW(1587) & ChrW(1601) & ChrW(1606) & ChrW(1583)
       
    End Select

    Select Case Format
    
    Case 1
            m2s = Rooz & "," & iYear & "/" & iMonth & "/" & iDay
    Case 2
        m2s = Rooz & " " & horofi(iDay) & " " & mah & " " & ChrW(1605) & ChrW(1575) & ChrW(1607) & " " & horofi(iYear)
    Case 3
        m2s = iYear
    Case 4
        m2s = iMonth
    Case 5
        m2s = iDay
    Case 0
        m2s = iYear & "/" & iMonth & "/" & iDay
    Case Else
        m2s = "Only one of this number as format(0,1,2,3,4,5) for help visit http://sakhteman.wordpress.com"
    End Select
    
End Function
Function horofi(ByVal Number As Double) As String
Number = Int(Number)
If Number = 0 Then Adad = ChrW(1589) & ChrW(1601) & ChrW(1585): Exit Function

Dim Flag As Boolean
Dim s As String
Dim i, L As Byte
Dim K(1 To 5) As Double

s = Trim(Str(Number))
L = Len(s)
If L > 15 Then
Adad = ChrW(1576) & ChrW(1587) & ChrW(1610) & ChrW(1575) & ChrW(1585) & ChrW(1576) & ChrW(1586) & ChrW(1585) & ChrW(1711) & " "
Exit Function
End If
For i = 1 To 15 - L
s = "0" & s
Next i
For i = 1 To Int((L / 3) + 0.99)
K(5 - i + 1) = Val(Mid(s, 3 * (5 - i) + 1, 3))
Next i
Flag = False
s = " "
For i = 1 To 5
If K(i) <> 0 Then
Select Case i
Case 1
s = s & Three(K(i)) & " " & ChrW(1578) & ChrW(1585) & ChrW(1610) & ChrW(1604) & ChrW(1610) & ChrW(1608) & ChrW(1606) & " "
Flag = True
Case 2
s = s & IIf(Flag = True, ChrW(1608), " ") & Three(K(i)) & " " & ChrW(1605) & ChrW(1610) & ChrW(1604) & ChrW(1610) & ChrW(1575) & ChrW(1585) & ChrW(1583) & " "
Flag = True
Case 3
s = s & IIf(Flag = True, ChrW(1608), " ") & Three(K(i)) & " " & ChrW(1605) & ChrW(1610) & ChrW(1604) & ChrW(1610) & ChrW(1608) & ChrW(1606) & " "
Flag = True
Case 4
s = s & IIf(Flag = True, ChrW(1608), " ") & Three(K(i)) & " " & ChrW(1607) & ChrW(1586) & ChrW(1575) & ChrW(1585) & " "
Flag = True
Case 5
s = s & IIf(Flag = True, ChrW(1608), " ") & Three(K(i)) & " "
End Select
End If
Next i
horofi = Trim(s)
End Function

Function Three(ByVal Number As Integer) As String
Dim s As String
Dim i, L As Long
Dim h(1 To 3) As Byte
Dim Flag As Boolean
L = Len(Trim(Str(Number)))
If Number = 0 Then
Three = " "
Exit Function
End If
If Number = 100 Then
Three = ChrW(1610) & ChrW(1603) & ChrW(1589) & ChrW(1583) & " "
Exit Function
End If

If L = 2 Then h(1) = 0
If L = 1 Then
h(1) = 0
h(2) = 0
End If

For i = 1 To L
h(3 - i + 1) = Mid(Trim(Str(Number)), L - i + 1, 1)
Next i

Select Case h(1)
Case 1
s = " " & ChrW(1610) & ChrW(1603) & ChrW(1589) & ChrW(1583) & " "
Case 2
s = " " & ChrW(1583) & ChrW(1608) & ChrW(1610) & ChrW(1587) & ChrW(1578) & " "
Case 3
s = " " & ChrW(1587) & ChrW(1610) & ChrW(1589) & ChrW(1583) & " "
Case 4
s = " " & ChrW(1670) & ChrW(1607) & ChrW(1575) & ChrW(1585) & ChrW(1589) & ChrW(1583) & " "
Case 5
s = " " & ChrW(1662) & ChrW(1575) & ChrW(1606) & ChrW(1589) & ChrW(1583) & " "
Case 6
s = " " & ChrW(1588) & ChrW(1588) & ChrW(1589) & ChrW(1583) & " "
Case 7
s = " " & ChrW(1607) & ChrW(1601) & ChrW(1578) & ChrW(1589) & ChrW(1583) & " "
Case 8
s = " " & ChrW(1607) & ChrW(1588) & ChrW(1578) & ChrW(1589) & ChrW(1583) & " "
Case 9
s = " " & ChrW(1606) & ChrW(1607) & ChrW(1589) & ChrW(1583) & " "
End Select

Select Case h(2)
Case 1
Select Case h(3)
Case 0
s = s & ChrW(1608) & " " & ChrW(1583) & ChrW(1607) & "  "
Case 1
s = s & ChrW(1608) & " " & ChrW(1610) & ChrW(1575) & ChrW(1586) & ChrW(1583) & ChrW(1607) & " "
Case 2
s = s & ChrW(1608) & " " & ChrW(1583) & ChrW(1608) & ChrW(1575) & ChrW(1586) & ChrW(1583) & ChrW(1607) & " "
Case 3
s = s & ChrW(1608) & " " & ChrW(1587) & ChrW(1610) & ChrW(1586) & ChrW(1583) & ChrW(1607) & " "
Case 4
s = s & ChrW(1608) & " " & ChrW(1670) & ChrW(1607) & ChrW(1575) & ChrW(1585) & ChrW(1583) & ChrW(1607) & " "
Case 5
s = s & ChrW(1608) & " " & ChrW(1662) & ChrW(1575) & ChrW(1606) & ChrW(1586) & ChrW(1583) & ChrW(1607) & " "
Case 6
s = s & ChrW(1608) & " " & ChrW(1588) & ChrW(1575) & ChrW(1606) & ChrW(1586) & ChrW(1583) & ChrW(1607) & " "
Case 7
s = s & ChrW(1608) & " " & ChrW(1607) & ChrW(1601) & ChrW(1583) & ChrW(1607) & " "
Case 8
s = s & ChrW(1608) & " " & ChrW(1607) & ChrW(1580) & ChrW(1583) & ChrW(1607) & " "
Case 9
s = s & ChrW(1608) & " " & ChrW(1606) & ChrW(1608) & ChrW(1586) & ChrW(1583) & ChrW(1607) & " "
End Select

Case 2
s = s & ChrW(1608) & " " & ChrW(1576) & ChrW(1610) & ChrW(1587) & ChrW(1578) & " "
Case 3
s = s & ChrW(1608) & " " & ChrW(1587) & ChrW(1610) & " "
Case 4
s = s & ChrW(1608) & " " & ChrW(1670) & ChrW(1607) & ChrW(1604) & " "
Case 5
s = s & ChrW(1608) & " " & ChrW(1662) & ChrW(1606) & ChrW(1580) & ChrW(1575) & ChrW(1607) & " "
Case 6
s = s & ChrW(1608) & " " & ChrW(1588) & ChrW(1589) & ChrW(1578) & " "
Case 7
s = s & ChrW(1608) & " " & ChrW(1607) & ChrW(1601) & ChrW(1578) & ChrW(1575) & ChrW(1583) & " "
Case 8
s = s & ChrW(1608) & " " & ChrW(1607) & ChrW(1588) & ChrW(1578) & ChrW(1575) & ChrW(1583) & " "
Case 9
s = s & ChrW(1608) & " " & ChrW(1606) & ChrW(1608) & ChrW(1583) & " "
End Select

If h(2) <> 1 Then
Select Case h(3)
Case 1
s = s & ChrW(1608) & " " & ChrW(1610) & ChrW(1603)
Case 2
s = s & ChrW(1608) & " " & ChrW(1583) & ChrW(1608)
Case 3
s = s & ChrW(1608) & " " & ChrW(1587) & ChrW(1607)
Case 4
s = s & ChrW(1608) & " " & ChrW(1670) & ChrW(1607) & ChrW(1575) & ChrW(1585)
Case 5
s = s & ChrW(1608) & " " & ChrW(1662) & ChrW(1606) & ChrW(1580)
Case 6
s = s & ChrW(1608) & " " & ChrW(1588) & ChrW(1588)
Case 7
s = s & ChrW(1608) & " " & ChrW(1607) & ChrW(1601) & ChrW(1578)
Case 8
s = s & ChrW(1608) & " " & ChrW(1607) & ChrW(1588) & ChrW(1578)
Case 9
s = s & ChrW(1608) & " " & ChrW(1606) & ChrW(1607)
End Select
End If
s = IIf(L < 3, Right(s, Len(s) - 1), s)
Three = s
End Function

     Sub Delete_Every_Named_Range_With_A_Reference_Error()
         Dim nm As Object
         Dim mystr As String

         ' Loops through each name in the active workbook.
         For Each nm In ActiveWorkbook.Names

            ' Check for #REF! in the defined name reference.
            If InStr(1, nm.RefersTo, "#REF!") Then

               ' Delete the defined name if it is a match.
               nm.Delete

            End If
         Next

      End Sub

یه دکمه بزار و asign کن به Calc

اکسل به صورت دیفالت تاریخ شمسی رو نمیشناسه ، یا باید بگردید و یه افزونه ای پیدا کنید که این کار رو بکنه یا بهتره تاریخ میلادی بزنید.

برای محاسبه تفاوت  می تونید از این فرمول استفاده کنید. (با فرض اینکه تاریخ شما در ستون B هستش):

=Today()-B1

بعد می مونه رنگ دادن که باید از conditional formatting استفاده کنید ، نوع rule رو بزارید روی  format only cells that contains و بعد بگید greater than مثلا 45 رو با format که پایینش می دید مثلا رنگ قرمز تو بکگراند بده.