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?

I rewrote the code to make it easier to follow and to make the loops
esier to follow. the selection method you are using makes it difficult
to modify the code. I used intermediate variables so yo don't have to
select cells and use activecells. If yo understand the changes I made
you should be able to accomplish your goals.



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


Range(Columns("E:E"), Columns("E:E").End(xlToRight)).Delete


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
Set LastColCell = Range(startcell).Range(Selection.End(xlToRight)
Set LastCell = LastColCell.End(xlDown))
Set DataRange = Range(StartCell,LastCell)

mindate = Application.WorksheetFunction.Min(DataRange)
maxdate = Application.WorksheetFunction.Max(DataRange)

'Create date headings
Set DateHeading = Range(startcell).Offset(-1, columnoffset)

DateHeading.Formula = mindate
set StartDate = DateHeading.offset(1,0)
Set LastDate = StartDate.end(xldown)
Set DateRange(StartDate,EndDate)

for each cell in DateRange
cell.Formula = cell.Offset(0, -1).Value + frequency
if cell = MaxDate then
Set FirstDate = cell
exit for
end if

next cell


'Create gantt chart
set LastGanttCell = StartCell.end(xldown)
Set TaskRange = Range(StartCell,LastGanttCell)

For Each task In TaskRange
mindate = task.Value
maxdate = task.Offset(0, 1).Value
Set Endtask = task.Offset(0, columnoffset)

Set TaskRow = Range(Task,EndTask)

for each cell in Taskrow

if Cell = mindate then
Set LastDate = cell
exit for
end if
next cell

Loop
'Color cell until end date


Set GanttRange = Range(firstDate,LastDate)

GanttRange.Interior.ColorIndex = 3
Range("D1").EntireColumn.Hidden = True

Range("E1").Select
Set LastCell = Range("E1").End(xlToRight)

Set HeaderRange = Range("E1", LastCell)
With HeaderRange
NumberFormat = "dd/mm"

HorizontalAlignment = xlGeneral
VerticalAlignment = xlBottom
WrapText = False
Orientation = -90
AddIndent = False
IndentLevel = 0
ShrinkToFit = False
ReadingOrder = xlContext
MergeCells = False
End With
With HeaderRange.Font
Name = "Arial"
FontStyle = "Regular"
Size = 8
Strikethrough = False
Superscript = False
Subscript = False
OutlineFont = False
Shadow = False
Underline = xlUnderlineStyleNone
ColorIndex = xlAutomatic
End With

HeaderRange.EntireColumn.AutoFit


Application.ScreenUpdating = True
End Sub


--
joel
------------------------------------------------------------------------
joel's Profile: 229
View this thread: http://www.thecodecage.com/forumz/sh...d.php?t=186842

http://www.thecodecage.com/forumz/chat.php

Hi Joel,

Thanks for the reply - when I paste your code, the following 3 rows
are highlighted red as syntax errors:

Set LastColCell = Range(startcell).Range(Selection.End(xlToRight)
Set LastCell = LastColCell.End(xlDown))

Set DateRange(StartDate,EndDate)

I think the first is missing a closing parenthesis, and the second has
an extra one?

But I'm not sure about the third?

Thanks again for your help!

Chris

I didn't test the code but was trying to give you other methods for
writing code that where you would be able to get an outline of the Gantt
Chart rather than turning on the inside borders


This line I didn't remove the "SELECTION" property
from
Set LastColCell = Range(startcell).Range(Selection.End(xlToRight)
to
Set LastColCell = Range(startcell).End(xlToRight)


This line I didn't remove the parenthesis
from
Set LastCell = LastColCell.End(xlDown))
to
Set LastCell = LastColCell.End(xlDown)

This line I left the equal sign out
from
Set DateRange(StartDate,EndDate)
to
Set DateRange = Range(StartDate,EndDate)


--
joel
------------------------------------------------------------------------
joel's Profile: 229
View this thread: http://www.thecodecage.com/forumz/sh...d.php?t=186842

http://www.thecodecage.com/forumz/chat.php

On Mar 12, 11:52*pm, joel wrote:
I didn't test the code but was trying to give you other methods for
writing code that where you would be able to get an outline of the Gantt
Chart rather than turning on the inside borders

This line I didn't remove the "SELECTION" property
from
Set LastColCell = Range(startcell).Range(Selection.End(xlToRight)
to
Set LastColCell = Range(startcell).End(xlToRight)

This line I didn't remove the parenthesis
from
Set LastCell = LastColCell.End(xlDown))
to
Set LastCell = LastColCell.End(xlDown)

This line I left the equal sign out
from
Set DateRange(StartDate,EndDate)
to
Set DateRange = Range(StartDate,EndDate)

--
joel
------------------------------------------------------------------------
joel's Profile: 229
View this thread:http://www.thecodecage.com/forumz/sh...d.php?t=186842

http://www.thecodecage.com/forumz/chat.php


Hi Joel,

I'm very appreciative of your help on this - I realized you probably
didn't test the code, but to be honest I'm quite out of my depth with
what you've given me so if you don't mind helping me just a little
more that would be fantastic!

I made the changes you suggested, but the code is now breaking at the
startcell in the first line below with a 'Compile error - invalid
qualifier' -

'Create gantt chart
Set LastGanttCell = startcell.End(xlDown)
Set TaskRange = Range(startcell, LastGanttCell)



I took an educated guess at fixing it by changing:

Set LastGanttCell = startcell.End(xlDown)

to

Set LastGanttCell = Range(startcell).End(xlDown)


which Excel accepts, but now the code breaks at the Loop with a
'Compile error - Loop without do'?


Sorry to as for your help again Joel, but I feel we're very close to
making this work. If you need an example what I want to use this in,
please let me know!

Thanks again
Chris

I got rid of all the compiler errors. I'm having a lot of problems
understanding your code because your original code is jumping around the
worksheet and suspect there are much better ways of achieving what yo
are trying to do. I'm not sure how you columns are laid out. I'vbe
worked a lot over the years with microsoft project so I understand Gantt
charts. I'm not sure if the dates are sequential going down the rows or
are random like most projects.

I would orgainze code my code by simply moving down the worksheet like
this
'this isn't code but a description of How I would do it
For RowCount = 1 to LastRow
''check if new task
if New Task set Start Date to Task Date and Set End Date to Task
Date
if Last Row of task Create bar for Task
if Task Date EndDate then set EndDate to Task Date
if Task Date < StartDate then set Start Date to Task Date
next rowCount





VBA 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


Range(Columns("E:E"), Columns("E:E").End(xlToRight)).Delete


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
Set LastColCell = Range(startcell).End(xlToRight)
Set LastCell = LastColCell.End(xlDown)
Set DataRange = Range(startcell, LastCell)

mindate = Application.WorksheetFunction.Min(DataRange)
maxdate = Application.WorksheetFunction.Max(DataRange)

'Create date headings
Set DateHeading = Range(startcell).Offset(-1, columnoffset)

DateHeading.Formula = mindate
Set StartDate = DateHeading.Offset(1, 0)
Set LastDate = StartDate.End(xlDown)
Set DateRange = Range(StartDate, EndDate)

For Each cell In DateRange
cell.Formula = cell.Offset(0, -1).Value + frequency
If cell = maxdate Then
Set firstDate = cell
Exit For
End If

Next cell


'Create gantt chart
Set LastGanttCell = Range(startcell).End(xlDown)
Set TaskRange = Range(startcell, LastGanttCell)

For Each task In TaskRange
mindate = task.Value
maxdate = task.Offset(0, 1).Value
Set EndTask = task.Offset(0, columnoffset)

Set Taskrow = Range(task, EndTask)

For Each cell In Taskrow

If cell = mindate Then
Set LastDate = cell
Exit For
End If
Next cell
Next task
'Color cell until end date


Set GanttRange = Range(firstDate, LastDate)

GanttRange.Interior.ColorIndex = 3
Range("D1").EntireColumn.Hidden = True

Range("E1").Select
Set LastCell = Range("E1").End(xlToRight)

Set HeaderRange = Range("E1", LastCell)

With HeaderRange
.NumberFormat = "dd/mm"

.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = -90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

With HeaderRange.Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With

HeaderRange.EntireColumn.AutoFit


Application.ScreenUpdating = True
End Sub
--------------------


--
joel
------------------------------------------------------------------------
joel's Profile: 229
View this thread: http://www.thecodecage.com/forumz/sh...d.php?t=186842

http://www.thecodecage.com/forumz/chat.php