7.27.2558

Auto Fill Color Rows Based On Cell Value


Public Sub Shade_Timeline()
Dim i, r, start_shade, end_shade, start_year, start_week, end_year, end_week As Integer
Dim star_date, end_date As Variant
i = 5  'This code is start Row=15
For i = i To 10
    If IsEmpty(Cells(i, 2).Value) = False Then
            start_year = DatePart("yyyy", Cells(i, 2))
            start_week = DatePart("ww", Cells(i, 2))
            end_year = DatePart("yyyy", Cells(i, 3))
            end_week = DatePart("ww", Cells(i, 3))            
            Select Case start_year
                Case 1899                   
                   Range(Cells(i, 1), Cells(i, 200)).Select
                   i = i - 1
                   Selection.Delete Shift:=xlUp             
                Case 2011
                    start_shade = 5 + start_week
                    If end_year = 2011 Then end_shade = 5 + end_week
                    If end_year = 2012 Then end_shade = 5 + 52 +                           end_week
                    If end_year = 2013 Then end_shade = 5 + 52 + 52                       + end_week
                    Range(Cells(i, start_shade), Cells(i,                                 end_shade)).Interior.Color = i * 9500
                Case 2012
                    start_shade = 57 + start_week
                    If end_year = 2012 Then end_shade = 57 +                               end_week
                    If end_year = 2013 Then end_shade = 57 + 52 +                         end_week
                    Range(Cells(i, start_shade), Cells(i,                                 end_shade)).Interior.Color = i * 6500
                Case 2013
                    start_shade = 109 + start_week
                    If end_year = 2013 Then end_shade = 109 +                             end_week
                    If end_year = 2014 Then end_shade = 109 + 52 +                         end_week
                    Range(Cells(i, start_shade), Cells(i,                                 end_shade)).Interior.Color = i * 3500
            End Select
    End If
Next
  Range("A1").Select
End Sub

ไม่มีความคิดเห็น:

แสดงความคิดเห็น