View Single Post
  #1   Report Post  
Posted to microsoft.public.excel.programming
nofam nofam is offline
external usenet poster
 
Posts: 10
Default Select contiguous cells by ActiveCell.Interior.ColorIndex and applyborders

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?