VBA to draw border around column containing current week

sparkytech

Board Regular
Joined
Mar 6, 2018
Messages
96
Office Version
  1. 365
  2. 2019
I have a worksheet containing a VBA generated GANTT chart. The data for the GANTT chart comes from another sheet and is dynamic, so the number of rows on the GANTT varies, as does the number of columns. There are "week start" dates on row 4 beginning at column J. How can I fill the columns with a pattern and draw a border around the entire column that contains data? Disclaimer: I didn't create this particular GANTT chart, and the VBA is by others, so I can't explain everything about it's function.

VBA Code:
Sub DrawScale()

Dim Ncolumns As Integer 'Number of columns of the scale
Dim StartDate As Long   'Start date for index
Dim EndDate As Long     'End date to find number of columns
Dim iCol As Integer     'Col index for for loop
Dim wkday As Integer    'Day of week for given date
Dim InDate As Long
Dim EndCol As Integer

EndDate = Sheet3.Cells(2, 2)
Ncolumns = 1

'Finds the number of columns needed based on whole weeks by adding 7 to the start limit
'until it exceeds the end limit
Do Until EndDate >= Sheet3.Cells(2, 3)
    EndDate = EndDate + 7
    Ncolumns = Ncolumns + 1
Loop

'Find the first day of the week for the start of the column labels
wkday = Weekday(Sheet3.Cells(2, 2))
StartDate = Sheet3.Cells(2, 2) - wkday + 1
InDate = StartDate
EndCol = 9 + Ncolumns

'Label each of the columns with the first date of that week and format as short dates
For iCol = 10 To EndCol
    Sheet3.Cells(4, iCol) = InDate
    Sheet3.Cells(4, iCol).NumberFormat = "m/d/yy"
    InDate = InDate + 7
    Sheet3.Cells(4, iCol).Orientation = 90
Next iCol

End Sub

Sub PickColor(CRow)
'Checks to see if a color has been assigned to a TCR; if one has been assigned it matches that color
'If not a random color will be generated and applied.
    Dim r As Byte
    Dim g As Byte
    Dim b As Byte
    Dim bR As Long   'Bottom row of table
    Dim lC As Long   'Last column of table
    Dim indRow As Integer
    Dim TempNo As Long
    
    
    'Find the bottom row and last column of the table
    bR = Sheet3.Cells.Find(What:="*", After:=Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
    lC = Sheet3.Cells.Find(What:="*", After:=Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
    
    'bnewport commented out ~ Find three random numbers to change the cell colors later
    'r = WorksheetFunction.RandBetween(0, 255)
    'g = WorksheetFunction.RandBetween(0, 255)
    'b = WorksheetFunction.RandBetween(0, 255)
    
    'bnewport added ~ Find three random numbers to change the cell colors later ~ LIMIT TO PASTELS
    r = WorksheetFunction.RandBetween(128, 255)
    g = WorksheetFunction.RandBetween(128, 255)
    b = WorksheetFunction.RandBetween(128, 255)
    
    'Establish the first row to start - using 5 to skip all the titles
    indRow = 5
    
    'Checks all of the rows above the row that comes in as variable
    Do Until indRow > CRow
        'If the cell of the indRow does not have a color then the random color is assigned to the row to be colored
        'if the indRow cell does have color and if the TCR name is the same then the color of the indRow is applied
        'to the row that is to be colored
        If Sheet3.Cells(indRow, 1).Interior.ColorIndex = xlNone Then
            Sheet3.Cells(CRow, 1).Interior.Color = RGB(r, g, b)
        ElseIf Sheet3.Cells(CRow, 2) = Sheet3.Cells(indRow, 2) Then
            Sheet3.Cells(CRow, 1).Interior.Color = Sheet3.Cells(indRow, 1).Interior.Color
        End If
        indRow = indRow + 1
    Loop
    
End Sub

Sub DrawOneRow(DRow)
'Draws a single row of the Gantt chart based on the project start date and end date
'Must be run after PickColor to have a color assigned to that row.
    Dim bR As Long   'Bottom row of table
    Dim lC As Long   'Last column of table
    Dim indCol As Integer
        
    'Find the bottom row and last column of the table
    bR = Sheet3.Cells.Find(What:="*", After:=Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
    lC = Sheet3.Cells.Find(What:="*", After:=Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
    
    For indCol = 11 To lC
        If Sheet3.Cells(4, indCol) >= Sheet3.Cells(DRow, 7) And Sheet3.Cells(DRow, 8) >= Sheet3.Cells(4, indCol) Then
            Sheet3.Cells(DRow, indCol).Interior.Color = Sheet3.Cells(DRow, 1).Interior.Color
        End If
    Next indCol

End Sub

Sub DrawItAll()
'Draws the scale, assigns colors and draws all the rows of the Gantt Chart
    Dim bR As Long   'Bottom row of table
    Dim lC As Long   'Last column of table
    Dim inRow As Integer
    
    'Find the bottom row and last column of the table
    bR = Sheet3.Cells.Find(What:="*", After:=Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
    lC = Sheet3.Cells.Find(What:="*", After:=Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
    
    'Turn off screen updates to improve performance
    Application.ScreenUpdating = False

    Call DrawScale

    For inRow = 5 To bR
        Call PickColor(inRow)
        Call DrawOneRow(inRow)
    Next inRow

    Call GanttAsTable.CreateTable
    
    'Turn on screen updates
    Application.ScreenUpdating = True
        
End Sub
GANTT25.jpg
 
You can try this to see if the dates wiill convert in code to date data types. If they do , then it should put the border around the right collumn.

Rich (BB code):
Sub t()
Dim i As Long
    For i = 10 To 36
        If CDate(Cells(4, i).Value) <= Date And CDate(Cells(4, i + 1).Value) > Date Then
            Cells(5, i).Resize(22).BorderAround 1, xlThick
            Cells(5, i).Resize(22).Interior.Pattern = 14
        End If
    Next
End Sub
 
Last edited:
Upvote 0

Excel Facts

Can a formula spear through sheets?
Use =SUM(January:December!E7) to sum E7 on all of the sheets from January through December
Thanks! I combined both pieces of code into a new module for simplicity, and so I could run the macro after the Gantt chart is drawn. I am still not having any success with the border.

VBA Code:
Sub TtoCols()
    Dim i As Long
    Dim j As Long
    For i = 10 To 62
        Cells(4, i).TextToColumns Destination:=Cells(4, i), DataType:=xlDelimited, _
        TextQualifier:=xlSingleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 3), TrailingMinusNumbers:=True
    Next
    Range(Cells(4, 10), Cells(4, 62)).NumberFormat = "mm/dd/yyyy"
    
    For j = 10 To 36
        If Cells(4, j).Value <= Date And Cells(4, j + 1).Value > Date Then
            Cells(5, j).Resize(22).BorderAround 1, xlThick
            Cells(5, j).Resize(22).Interior.Pattern = 14
        End If
    Next
End Sub
 
Upvote 0
You already have borders in your chart, so if you do now make the new border a different color or broader, you would not be able to detect a change. That is why I changed this line
VBA Code:
Cells(5, j).Resize(22).BorderAround 1, xlThick
to xlThick as the line weight. Have you tried using the F8 function key to step through the code one line at a time and see if it is acturally finding the correct column? To do that, open the editor, left click in the body of the macro to tell VBA where you want to work, then press and release the F8 key. The title line of the macro should be highlighted. Then you can advance the highlight one row at a time to execute the code for the previously highlighted line. If you resize and move the editor screen, you can see the worksheet and follow what the code should be doing. Hover the mouse pointer over variables so the intellisense will display the values. This is a troubleshooting tool that I use to find where the code is not doing what I expect it to do.
 
Upvote 0

Forum statistics

Threads
1,212,927
Messages
6,110,710
Members
448,293
Latest member
jin kazuya

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top