Hide columns based on dates in rows (Gantt table header) VBA

Question

I've created a Gantt table in Excel and I'm using macros to expand or collapse the dates into weeks, workweeks, calender weeks and months. The trick is: Saturdays and Sundays are hashed with conditional formatting and therefore shouldn't appear when collapsed. So far I've managed to make all but the months option work correctly. here is the code to collapse month that I have so far:

    Sub Month_Collapse()
    Dim LastCol As Long, x As Long    
    Columns("H:SSS").ColumnWidth = 3.45

'Hide Columns
    LastCol = ActiveSheet.Cells(4, Columns.Count).End(xlToLeft).Column
    For x = 8 To LastCol
        If (Cells(4, x).Text) = 28 And (Cells(5, x).Text) <> "Sat" And (Cells(5, x).Text) <> "Sun" Then
            Columns(x).Hidden = False          'ColumnWidth = 10
        Else
            Columns(x).Hidden = True    
        End If
    Next    

End Sub

Row 2 is populated with months. Row 4 is populated with days in number. Like "14". Row 5 is populated with weekdays as text. like "Mon" or "Sat". I've also tried to include the following, but than too many columns are displayed.

 If (Cells(4, x).Text) = 28 And (Cells(5, x).Text) <> "Sat" And (Cells(5, x).Text) <> "Sun" Then
            Columns(x).Hidden = False
        ElseIf (Cells(4, x).Text) = 29 And (Cells(5, x).Text) <> "Sat" And (Cells(5, x).Text) <> "Sun" Then
            Columns(x).Hidden = False
        ElseIf (Cells(4, x).Text) = 30 And (Cells(5, x).Text) <> "Sat" And (Cells(5, x).Text) <> "Sun" Then
            Columns(x).Hidden = False

I could possible also post the code that generates the header with the dates and the code that collapses the weeks. Not sure if too long to post here already...

Image with header row visible

enter image description here

Image "collapsed"

enter image description here

EDIT: Next the macro that creates the header. After created I´d like a macro to hide all columns except the column with last day of each month. However if such day is a weekend day, then the macro should take the previous Friday.

    Sub Create_Date_Header_Macro()
Dim InitialCell As Range
Dim InitialDate As Date

    '====================================================================================
    'Project starting date
    '''InitialDate = "01.05.2015"  ' example
        InitialDate = Application.InputBox(prompt:="Enter initial date:       (dd.mm.yyyy)")
        If InitialDate = False Then Exit Sub
    '====================================================================================
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False

        ActiveSheet.Unprotect
        Cells.Select
        Selection.Locked = False

        Range("H1:ZZ5").ClearContents
        Range("H1:ZZ5").UnMerge


        Set InitialCell = Range("G1")
        InitialCell.Activate
        ActiveCell.Offset(3, 1) = InitialDate
    '    ActiveCell.Offset(3, 1).NumberFormat = "d-mmm"     'Change date display mode here
        ActiveCell.Offset(3, 1).NumberFormat = "dd"
    'add week number
        ActiveCell.Offset(2, 1).FormulaR1C1 = "=WEEKNUM(R[1]C,2)"
        ActiveCell.Offset(2, 1).NumberFormat = "General"
    'add month
        ActiveCell.Offset(1, 1).FormulaR1C1 = _
        "=IF(MONTH(R[2]C)=1,""January"",IF(MONTH(R[2]C)=2,""February"",IF(MONTH(R[2]C)=3,""March"",IF(MONTH(R[2]C)=4,""April"",IF(MONTH(R[2]C)=5,""May"",IF(MONTH(R[2]C)=6,""June"",IF(MONTH(R[2]C)=7,""July"",IF(MONTH(R[2]C)=8,""August"",IF(MONTH(R[2]C)=9,""September"",IF(MONTH(R[2]C)=10,""October"",IF(MONTH(R[2]C)=11,""November"",IF(MONTH(R[2]C)=12,""December""))))))))))))"
    'add weekday
        ActiveCell.Offset(4, 1).FormulaR1C1 = "=R[-1]C"
        ActiveCell.Offset(4, 1).NumberFormat = "[$-2C09]DDD;@"
    'add year
        ActiveCell.Offset(0, 1).FormulaR1C1 = "=Year(R[3]C)"
        ActiveCell.Offset(0, 1).NumberFormat = "General"
    'Copy formats to next column
        ActiveCell.Offset(0, 1).Range("A1:A5").Select
        ActiveCell.Activate
        Selection.Copy
        ActiveCell.Offset(0, 1).Range("A1").Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
    ' date is equal starting date + 1
        ActiveCell.Offset(3, 0).FormulaR1C1 = "=RC[-1]+1"
    'Fill header
        Selection.AutoFill Destination:=ActiveCell.Range("A1:AE5"), Type:= _
        xlFillDefault

    'Streatch Table Conditional Formats into columns
        Columns("AA:AA").Select
        Selection.AutoFill Destination:=Columns("AA:TT"), Type:=xlFillDefault

    'Select all dates
        Range("H1:H5").Select
        Range(Selection, Selection.End(xlToRight)).Select
    'Copy + Paste Especial: Values
        With Selection
            .Copy
            .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
            .Columns.AutoFit
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With


        Call MergeCells
    '    Call Organize

        Range("H8").Select


        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End Sub


    Private Sub MergeCells()

        Dim rngMerge As Range, cell As Range
        Set rngMerge = Range("H2:SSS3")     'set ranges to be merged here

    MergeAgain:
        For Each cell In rngMerge
            If cell.Value = cell.Offset(0, 1).Value And IsEmpty(cell) = False Then
                Range(cell, cell.Offset(0, 1)).Merge
                GoTo MergeAgain
            End If
        Next

    'Year cells are formated in same size as month cells
        Rows(2).Select
        Selection.Copy
        Rows(1).Select
        Selection.PasteSpecial Paste:=xlPasteFormats
        Selection.NumberFormat = "General"
        Application.CutCopyMode = False


    End Sub

If you have access to MS-Project you should really use it instead, it is much better suited for what you are trying to achieve — Jeanno, May 11 '15 at 20:32
@Jeanno, the case is I don't. At work my MS-Office options are limited and I can't install private software. — cjgc, May 11 '15 at 20:35
It is not obvious from your code what you mean by collapse. It seems you just want to hide columns? Can you post a picture or better describe the expected result of this code? — Byron Wall, May 11 '15 at 20:46
With all that use of `Select`, `ActiveCell`, `Selection` etc you are creating a monster here. It will quickly become unmanageable. [See here for how to avoid them](http://stackoverflow.com/a/10717999/445425) — chris neilsen, May 11 '15 at 21:33
Thank you for the link @chris !! Would you know if this impacts performance? I did use a lot of the recorder. — cjgc, May 11 '15 at 21:44
@cjgc Three primary reasons to avoid `Select` etc: it's slower, it's error prone, it's hard to read/maintain. As for the recorder, it's a great way to see what objects/properties are used to achieve a particular action. But it does produce highly sub-optimal code. You should use it as a learning tool, not to produce finished code. — chris neilsen, May 12 '15 at 01:52
That was a very useful link @chris. The code looks cleaner now. — cjgc, May 12 '15 at 11:03

score 1 · Accepted Answer · answered May 12 '15 at 03:18

Here's a function that hides all but the last working day of the month. It assumes that row 4 contains an actual date (that happens to be formatted to show only the day).

Sub Month_Collapse()

Dim LastCol As Long, x As Long
Dim CurMonth As Integer, PriorMonth As Integer
Dim ColDate As Date, NextMonth As Date
Dim LastWorkingDay As Integer

LastCol = ActiveSheet.Cells(4, Columns.Count).End(xlToLeft).Column
Range(Columns(8), Columns(LastCol)).ColumnWidth = 3.45

For x = 8 To LastCol
    ColDate = Cells(4, x)
    CurMonth = Month(ColDate)
    If CurMonth <> PriorMonth Then
        NextMonth = DateSerial(Year(ColDate), Month(ColDate) + 1, 1)
        LastWorkingDay = Day(Application.WorkDay(NextMonth, -1))
    End If
    If Day(ColDate) <> LastWorkingDay Then
        Columns(x).Hidden = True
    End If
Next x

End Sub

Hide columns based on dates in rows (Gantt table header) VBA

1 Answers1