CODEWITHSUNDEEP
excelvbaexcel-formula
Kzhel
Kzhel

Reputation: 23

Cell background Colors reference to dates on other sheet

I Have Two Sheets. Sheet1 Sheet2

The code I use works perfectly but for single row as per expected result If date is duplicate next color should come under same month. but with this code it is taking the last color and putting it.

Expected resullt

This is code I am using

Sub ColorsCell()

Dim dt As Date: Dim t0 As Date: Dim t1 As Date: Dim t2 As Date: Dim t3 As Date: Dim t4 As Date: Dim t5 As Date
Dim rgT As Range: Dim rgN As Range: Dim c As Range: Dim cell As Range

With Sheets("Sheet5")
    Set rgT = .Range("A2", .Range("A2").End(xlDown))
End With

With Sheets("Sheet3")
    .Range("B6:bu11, b13:bu18, B20:bu25, b27:bu32, B34:bu39").Interior.Color = xlNone
    Set rgN = .Columns(1).SpecialCells(xlConstants)
End With

dt = "1-jan-2023"

For Each cell In rgT

    t0 = cell.Offset(0, 1).Value
    t1 = cell.Offset(0, 2).Value
    t2 = cell.Offset(0, 3).Value
    t3 = cell.Offset(0, 4).Value
    t4 = cell.Offset(0, 5).Value
    t5 = cell.Offset(0, 6).Value

    Set c = rgN.Find(cell.Value, lookat:=xlWhole)

    If Not c Is Nothing Then
        c.Offset(0, DateDiff("m", dt, t0) + 1).Interior.Color = vbGreen
        c.Offset(0, DateDiff("m", dt, t1) + 1).Interior.Color = vbRed
        c.Offset(0, DateDiff("m", dt, t2) + 1).Interior.Color = vbBlack
        c.Offset(0, DateDiff("m", dt, t3) + 1).Interior.Color = vbYellow
        c.Offset(0, DateDiff("m", dt, t4) + 1).Interior.Color = vbBlue
        c.Offset(0, DateDiff("m", dt, t5) + 1).Interior.Color = vbCyan
    End If

Next

End Sub

Upvotes: 0

Views: 34

Answers (1)

Kzhel
Kzhel

Reputation: 23

I unmerged the cells with name than this code is working

Sub ColorsCell()
Dim dt As Date: Dim t0 As Date: Dim t1 As Date: Dim t2 As Date: Dim t3 As Date: Dim t4 As Date: Dim t5 As Date
Dim rgT As Range: Dim rgN As Range: Dim c As Range: Dim cell As Range
With Sheets("Sheet5")
    Set rgT = .Range("A2", .Range("A2").End(xlDown))
End With
With Sheets("Sheet3")
    .Range("B6:bu11, b13:bu18, B20:bu25, b27:bu32, B34:bu39").Interior.Color = xlNone
    Set rgN = .Columns(1).SpecialCells(xlConstants)
End With
dt = "1-jan-2023"
For Each cell In rgT
    t0 = cell.Offset(0, 1).Value
    t1 = cell.Offset(0, 2).Value
    t2 = cell.Offset(0, 3).Value
    t3 = cell.Offset(0, 4).Value
    t4 = cell.Offset(0, 5).Value
    t5 = cell.Offset(0, 6).Value
    Set c = rgN.Find(cell.Value, lookat:=xlWhole)
If Not c Is Nothing Then
   c.Offset(0, DateDiff("m", dt, t0) + 1).Interior.Color = vbGreen:
   c.Offset(0, DateDiff("m", dt, t1) + 1).Offset(1, 0).Interior.Color = vbRed:
   c.Offset(0, DateDiff("m", dt, t2) + 1).Offset(2, 0).Interior.Color = vbBlack
   c.Offset(0, DateDiff("m", dt, t3) + 1).Offset(3, 0).Interior.Color = vbYellow
   c.Offset(0, DateDiff("m", dt, t4) + 1).Offset(4, 0).Interior.Color = vbBlue
   c.Offset(0, DateDiff("m", dt, t5) + 1).Offset(5, 0).Interior.Color = vbCyan
End If
Next
End Sub

Thanks to @karma

Upvotes: 1

Related Questions