Home |
Search |
Today's Posts |
#1
![]()
Posted to microsoft.public.excel.programming
|
|||
|
|||
![]()
I've got some code that loops through a list of start/end dates and
fills in cells in each row based on the number of days between those dates (kind of like a Gantt chart) This works fine, but I'd like a way to add borders to the cell range so they stand out a bit better. The difficulty I have is that the borders are currently being added to each individual cell, rather than one border for the whole selection: Each set of selections must stay within the specific row, so I can't have borders applied across multiple rows (hope that makes sense!) Here is the code:Sub Gantt_Chart() Application.ScreenUpdating = False Dim mindate As Date Dim maxdate As Date Dim startcell As String Dim columnoffset As Integer Dim frequency As Integer Dim task As Variant Columns("E:E").Select Range(Selection, Selection.End(xlToRight)).Select Selection.Delete Shift:=xlToLeft startcell = "B2" 'Change this as necessary columnoffset = 3 'Where to start the gantt chart frequency = 1 'Could be 7 for weekly chart 'Get minimum and maximum dates Range(startcell).Select Range(Selection.End(xlToRight), Selection.End(xlDown)).Select mindate = Application.WorksheetFunction.Min(Selection) maxdate = Application.WorksheetFunction.Max(Selection) 'Create date headings Range(startcell).Offset(-1, columnoffset).Select ActiveCell.Formula = mindate ActiveCell.Offset(0, 1).Select Do Until ActiveCell.Offset(0, -1).Value = maxdate ActiveCell.Formula = ActiveCell.Offset(0, -1).Value + frequency ActiveCell.Offset(0, 1).Select Loop 'Create gantt chart Range(startcell, Range(startcell).End(xlDown)).Select For Each task In Selection mindate = task.Value maxdate = task.Offset(0, 1).Value task.Offset(0, columnoffset).Select 'Get starting cell Do Until Cells(Range(startcell).Row - 1, ActiveCell.Column).Value = mindate ActiveCell.Offset(0, 1).Select Loop 'Color cell until end date Do Until Cells(Range(startcell).Row - 1, ActiveCell.Column).Value maxdate Or Cells(Range(startcell).Row - 1, ActiveCell.Column).Text = "" ActiveCell.Interior.ColorIndex = 3 ActiveCell.Offset(0, 1).Select Loop Next Range(startcell).Select Columns("B:D").Select Range("D1").Activate Selection.EntireColumn.Hidden = True Range("E1").Select Range(Selection, Selection.End(xlToRight)).Select Selection.NumberFormat = "dd/mm" With Selection .HorizontalAlignment = xlGeneral .VerticalAlignment = xlBottom .WrapText = False .Orientation = -90 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With With Selection.Font .Name = "Arial" .FontStyle = "Regular" .Size = 8 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic End With Columns("E:E").Select Range(Selection, Selection.End(xlToRight)).Select Columns("E:IL").EntireColumn.AutoFit Application.ScreenUpdating = True End Sub The other thought I had was merging the colored cells so selecting them 'as one' would be easier, but in my experience, merging creates as many problems down the line as it solves!! Can you help me with the code so it selects all the cells in a row that it colors, and add one border to that range? |
Thread Tools | Search this Thread |
Display Modes | |
|
|
![]() |
||||
Thread | Forum | |||
more on interior.colorindex issue | Excel Programming | |||
interior.colorindex does not work? | Excel Programming | |||
problem with interior.colorindex | Excel Programming | |||
Use of Interior.ColorIndex | Excel Programming | |||
Testing for Interior.ColorIndex | Excel Programming |