根据行中的日期隐藏列（甘特图表头）VBA

Question

我在Excel中创建了甘特图表，我正在使用宏将日期扩展或折叠为数周，工作周，日历周和月。诀窍是：星期六和星期日使用条件格式进行哈希处理，因此在折叠时不应出现。到目前为止，我已经设法使所有月份选项正常工作。这是我到目前为止崩溃月份的代码：

    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

第2行填充了几个月。第4行填充了数天。喜欢“14”。第5行用工作日填充文本。喜欢“周一”或“周六”。 我还尝试包含以下内容，但显示的列数太多。

 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

我还可以发布生成标题的代码，其中包含日期和折叠周数的代码。不确定在这里发布的时间是否太长......

标题行可见的图片

图片“已崩溃”

编辑：接下来创建标题的宏。在创建之后我会像一个宏一样隐藏除了每个月的最后一天的列之外的所有列。但是，如果这一天是周末，那么宏应该采取上周五。

    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

Answer 1

这是一个隐藏除了本月最后一个工作日之外的所有功能的功能。它假定第4行包含实际日期（恰好被格式化为仅显示当天）。

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