VBA to draw border around column containing current week

sparkytech

New Member
Joined
Mar 6, 2018
Messages
33
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
 

Some videos you may like

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
VBA Code:
Sub t()
Dim i As Long
    For i = 10 To 36
        If Cells(5, i).Value <= Date And Cells(5, i + 1).Value > Date Then
            Cells(6, i).Resize(22).BorderAround 1, xlMedium
            Cells(6, i).Resize(22).Interior.Pattern = 14
        End If
    Next
End Sub
 

sparkytech

New Member
Joined
Mar 6, 2018
Messages
33
Thanks for the reply! I must be doing something wrong here. I added that sub to the end of my code, but nothing additional happens when the VBA draws the chart. Ideas?
 

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
If the date is not on row 5 then iyou would need to adust the code to reflect the correct row to text with the If statement. The code is based on the image provided.
 

sparkytech

New Member
Joined
Mar 6, 2018
Messages
33

ADVERTISEMENT

If the date is not on row 5 then iyou would need to adust the code to reflect the correct row to text with the If statement. The code is based on the image provided.
I changed the code to what I thought would be correct, but still can't get it to work. I am also providing an additional screen capture with sensitive info removed from columns B-F.

VBA Code:
Sub t()
Dim i As Long
    For i = 10 To 36
        If Cells(4, i).Value <= Date And Cells(4, i + 1).Value > Date Then
            Cells(5, i).Resize(22).BorderAround 1, xlMedium
            Cells(5, i).Resize(22).Interior.Pattern = 14
        End If
    Next
End Sub

GANTT2.jpg
 

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
Are you sure the values in row 4 are date data types, or are they text data types. Right click on one of the cells, then clidk format cells and choose Number at the top of the dialog box, not from the vertical list. Whatever is highlighted in the vertical list is the data type with how that cell is formated. We might have to do some converting to compare apples to apples instead of apples to oranges.
 

sparkytech

New Member
Joined
Mar 6, 2018
Messages
33

ADVERTISEMENT

Are you sure the values in row 4 are date data types, or are they text data types. Right click on one of the cells, then clidk format cells and choose Number at the top of the dialog box, not from the vertical list. Whatever is highlighted in the vertical list is the data type with how that cell is formated. We might have to do some converting to compare apples to apples instead of apples to oranges.
I never thought of that. It looks like the number type is Custom (m/d/yy) and the entire chart is created / dates populated with the VBA. Looking at the code above, is there a way to change this to a Number / Date format? This particular sheet is blank, the "Populate Data" macro is run, and the values in the columns A-I are imported. The "Draw Gantt" code above creates the GANTT chart with its formatting beginning at column J.
 

sparkytech

New Member
Joined
Mar 6, 2018
Messages
33
I never thought of that. It looks like the number type is Custom (m/d/yy) and the entire chart is created / dates populated with the VBA. Looking at the code above, is there a way to change this to a Number / Date format? This particular sheet is blank, the "Populate Data" macro is run, and the values in the columns A-I are imported. The "Draw Gantt" code above creates the GANTT chart with its formatting beginning at column J.
I am far from a VBA guru, but I did find this:

VBA Code:
'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

It looks like it *should* be creating the date headings in row 4 as a number format, but it seems like it creates the cells as "Custom" date format.
 

sparkytech

New Member
Joined
Mar 6, 2018
Messages
33
I am far from a VBA guru, but I did find this:

VBA Code:
'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

It looks like it *should* be creating the date headings in row 4 as a number format, but it seems like it creates the cells as "Custom" date format.
Something else I just noticed, is that the date headings show an error: "Text Date with 2-Digit Year".
 

MARK858

MrExcel MVP
Joined
Nov 12, 2010
Messages
14,005
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
  2. Mobile
Maybe try the code below (test on a copy of your data).

VBA Code:
Sub TtoCols()
    Dim i 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"
End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,128,016
Messages
5,628,150
Members
416,296
Latest member
smartua

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
Top