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? |
Select contiguous cells by ActiveCell.Interior.ColorIndex and applyborders
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 |
Select contiguous cells by ActiveCell.Interior.ColorIndex andapplyborders
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 |
Select contiguous cells by ActiveCell.Interior.ColorIndex and applyborders
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 |
Select contiguous cells by ActiveCell.Interior.ColorIndex andapplyborders
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 |
Select contiguous cells by ActiveCell.Interior.ColorIndex and applyborders
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 |
Select contiguous cells by ActiveCell.Interior.ColorIndex andapplyborders
On Mar 14, 12:17*am, joel wrote:
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 Hi Joel, Sorry, I should've clarified this a bit better to start with. I have a list of 3 columns (A, B, C): Event Start Date Finish Date Mar22 01/03/2010 09/03/2010 Mar11 05/03/2010 11/03/2010 Mar13 29/03/2010 16/04/2010 Apr09 01/04/2010 13/04/2010 What I'd like is a routine that firstly looks at the range B:C and finds the earliest date in B:B, and the latest date in C:C (in the above case it would be 01/03/2010 to 16/04/2010), and then populates row 1 on that sheet with each date in the range in consecutive cells (D1:AW1 in this case). Then I'd like the code to loop through each row (one event per row) and colour the cells for each event date range red with one solid border for the whole range - with the above examples, the code would colour cells D2:L2 and add one border for that whole range. So effectively what you end up with is a list of events running down Column A, a date range running across row 1, and a whole lot of individually colored and bordered bars for each event in the row. It's not really a Gantt chart in the true sense, as I'm not really interested in dependencies etc. I simply called it that because it kind of looks like one. Hope that makes sense Joel - please let me know if there's anything else you need. Cheers Chris |
Select contiguous cells by ActiveCell.Interior.ColorIndex and applyborders
this is how I would write the code. I think it is better to reference the top left corner of the data and label this point as start row and startcolumn. It gets confusing to move backwards to get a column. I had some problems due to the differences in US dates and English Dates (mm/dd/yy verses dd/mm/yy). I tried to make the code generic to work either location. The code now automatically puts the dates in the first row which your posted code didn't. I also like using good programming proactices. the code is more complicated but it prevents infinite loops from occuring. I also think your start and end dates may not be right in your original code. I would assume the bars should start the week of the task and not the following week if a task starts in the middle of the week. VBA Code: -------------------- Enum DateState findmindate findmaxdate End Enum Sub Gantt_Chart() Application.ScreenUpdating = False Dim mindate As Date Dim maxdate As Date Dim columnoffset As Integer Dim task As Variant Dim colcount As Integer Dim daterange As Range Dim firstdate As Range Dim frequency As Integer Dim GanttStart As Range Dim HeaderDates As Range Dim lastcol As Integer Dim lastdate As Range Dim lastrow As Integer Dim startrow As Integer Dim startcolumn As Integer Dim startdate As Date Dim startdatestr As String Dim timeperiod As Integer startrow = 1 'Change this as necessary startcolumn = 1 'Where to start the gantt chart ganttcolumnoffset = 3 startdatestr = "Jan-4-2010" startdate = DateValue(startdatestr) frequency = 7 'Could be 1 for weekly chart timeperiod = 52 'clear chart area Range(Cells(startrow, startcolumn + ganttcolumnoffset), _ Cells(Rows.Count, Columns.Count)).Delete 'create date headings in row 1 colcount = startcolumn + ganttcolumnoffset For timecount = 0 To (timeperiod - 1) Cells(startrow, colcount) = startdate + (frequency * timecount) colcount = colcount + 1 Next timecount Set firstdate = Cells(startrow, startcolumn + ganttcolumnoffset) Set lastdate = firstdate.End(xlToRight) Set daterange = Range(firstdate, lastdate) daterange.EntireColumn.AutoFit daterange.NumberFormat = "mm/dd/yy" lastrow = Cells(startrow + 2, startcolumn).End(xlDown).Row Set mindaterange = _ Range(Cells(startrow + 2, startcolumn + 1), _ Cells(lastrow, startcolumn + 1)) Set maxdaterange = _ Range(Cells(startrow + 2, startcolumn + 2), _ Cells(lastrow, startcolumn + 2)) 'create main task chart mindate = WorksheetFunction.Min(mindaterange) maxdate = WorksheetFunction.Max(maxdaterange) minheaderdatecolumn = daterange.Column State = DateState.findmindate For Each cell In daterange Select Case State Case DateState.findmindate If cell.Offset(0, 1) <= mindate Then minheaderdatecolumn = minheaderdatecolumn + 1 Else Datecount = mindate Cells(startrow + 1, minheaderdatecolumn) = Datecount maxheaderdatecolumn = minheaderdatecolumn State = DateState.findmaxdate End If Case DateState.findmaxdate If cell <= maxdate Then Datecount = Datecount + frequency maxheaderdatecolumn = maxheaderdatecolumn + 1 Cells(startrow + 1, maxheaderdatecolumn) = Datecount Else Exit For End If End Select Next cell Call makechart(startrow + 1, minheaderdatecolumn, _ maxheaderdatecolumn) 'create chart for each row For RowCount = (startrow + 2) To lastrow mindate = Cells(RowCount, startcolumn + 1) maxdate = Cells(RowCount, startcolumn + 2) minheaderdatecolumn = daterange.Column State = DateState.findmindate For Each cell In daterange Select Case State Case DateState.findmindate If cell.Offset(0, 1) <= mindate Then minheaderdatecolumn = minheaderdatecolumn + 1 Else Datecount = mindate Cells(RowCount, minheaderdatecolumn) = Datecount maxheaderdatecolumn = minheaderdatecolumn State = DateState.findmaxdate End If Case DateState.findmaxdate If cell <= maxdate Then Datecount = Datecount + frequency maxheaderdatecolumn = maxheaderdatecolumn + 1 Cells(RowCount, maxheaderdatecolumn) = Datecount Else Exit For End If End Select Next cell Call makechart(RowCount, minheaderdatecolumn, _ maxheaderdatecolumn) Next RowCount End Sub Sub makechart(ByVal myrow As Integer, _ ByVal startcol As Integer, ByVal endcol As Integer) Set GanttRange = Range(Cells(myrow, startcol), _ Cells(myrow, endcol)) 'format dates With GanttRange .Interior.ColorIndex = 3 .NumberFormat = "dd/mm" .HorizontalAlignment = xlGeneral .VerticalAlignment = xlBottom .WrapText = False .Orientation = -90 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With With GanttRange.Font .Name = "Arial" .FontStyle = "Regular" .Size = 8 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic End With With GanttRange .Interior.ColorIndex = 3 .Borders(xlDiagonalDown).LineStyle = xlNone .Borders(xlDiagonalUp).LineStyle = xlNone With .Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With .Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With .Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With .Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With .Borders(xlInsideVertical).LineStyle = xlNone End With 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 |
Select contiguous cells by ActiveCell.Interior.ColorIndex andapplyborders
On Mar 14, 10:46*pm, joel wrote:
this is how I would write the code. *I think it is better to reference the top left corner of the data and label this point as start row and startcolumn. *It gets confusing to move backwards to get a column. I had some problems due to the differences in US dates and English Dates (mm/dd/yy verses dd/mm/yy). *I tried to make the code generic to work either location. The code now automatically puts the dates in the first row which your posted code didn't. *I also like using good programming proactices. *the code is more complicated but it prevents infinite loops from occuring. I also think your start and end dates may not be right in your original code. *I would assume the bars should start the week of the task and not the following week if a task starts in the middle of the week. VBA Code: -------------------- Enum DateState * findmindate * findmaxdate * End Enum * Sub Gantt_Chart() * Application.ScreenUpdating = False * Dim mindate As Date * Dim maxdate As Date * Dim columnoffset As Integer * Dim task As Variant * Dim colcount As Integer * Dim daterange As Range * Dim firstdate As Range * Dim frequency As Integer * Dim GanttStart As Range * Dim HeaderDates As Range * Dim lastcol As Integer * Dim lastdate As Range * Dim lastrow As Integer * Dim startrow As Integer * Dim startcolumn As Integer * Dim startdate As Date * Dim startdatestr As String * Dim timeperiod As Integer * startrow = 1 'Change this as necessary * startcolumn = 1 'Where to start the gantt chart * ganttcolumnoffset = 3 * startdatestr = "Jan-4-2010" * startdate = DateValue(startdatestr) * frequency = 7 'Could be 1 for weekly chart * timeperiod = 52 * 'clear chart area * Range(Cells(startrow, startcolumn + ganttcolumnoffset), _ * Cells(Rows.Count, Columns.Count)).Delete * 'create date headings in row 1 * colcount = startcolumn + ganttcolumnoffset * For timecount = 0 To (timeperiod - 1) * Cells(startrow, colcount) = startdate + (frequency * timecount) * colcount = colcount + 1 * Next timecount * Set firstdate = Cells(startrow, startcolumn + ganttcolumnoffset) * Set lastdate = firstdate.End(xlToRight) * Set daterange = Range(firstdate, lastdate) * daterange.EntireColumn.AutoFit * daterange.NumberFormat = "mm/dd/yy" * lastrow = Cells(startrow + 2, startcolumn).End(xlDown).Row * Set mindaterange = _ * Range(Cells(startrow + 2, startcolumn + 1), _ * Cells(lastrow, startcolumn + 1)) * Set maxdaterange = _ * Range(Cells(startrow + 2, startcolumn + 2), _ * Cells(lastrow, startcolumn + 2)) * 'create main task chart * mindate = WorksheetFunction.Min(mindaterange) * maxdate = WorksheetFunction.Max(maxdaterange) * minheaderdatecolumn = daterange.Column * State = DateState.findmindate * For Each cell In daterange * Select Case State * Case DateState.findmindate * If cell.Offset(0, 1) <= mindate Then * minheaderdatecolumn = minheaderdatecolumn + 1 * Else * Datecount = mindate * Cells(startrow + 1, minheaderdatecolumn) = Datecount * maxheaderdatecolumn = minheaderdatecolumn * State = DateState.findmaxdate * End If * Case DateState.findmaxdate * If cell <= maxdate Then * Datecount = Datecount + frequency * maxheaderdatecolumn = maxheaderdatecolumn + 1 * Cells(startrow + 1, maxheaderdatecolumn) = Datecount * Else * Exit For * End If * End Select * Next cell * Call makechart(startrow + 1, minheaderdatecolumn, _ * maxheaderdatecolumn) * 'create chart for each row * For RowCount = (startrow + 2) To lastrow * mindate = Cells(RowCount, startcolumn + 1) * maxdate = Cells(RowCount, startcolumn + 2) * minheaderdatecolumn = daterange.Column * State = DateState.findmindate * For Each cell In daterange * Select Case State * Case DateState.findmindate * If cell.Offset(0, 1) <= mindate Then * minheaderdatecolumn = minheaderdatecolumn + 1 * Else * Datecount = mindate * Cells(RowCount, minheaderdatecolumn) = Datecount * maxheaderdatecolumn = minheaderdatecolumn * State = DateState.findmaxdate * End If * Case DateState.findmaxdate * If cell <= maxdate Then * Datecount = Datecount + frequency * maxheaderdatecolumn = maxheaderdatecolumn + 1 * Cells(RowCount, maxheaderdatecolumn) = Datecount * Else * Exit For * End If * End Select * Next cell * Call makechart(RowCount, minheaderdatecolumn, _ * maxheaderdatecolumn) * Next RowCount * End Sub * Sub makechart(ByVal myrow As Integer, _ * ByVal startcol As Integer, ByVal endcol As Integer) * Set GanttRange = Range(Cells(myrow, startcol), _ * Cells(myrow, endcol)) * 'format dates * With GanttRange * .Interior.ColorIndex= 3 * .NumberFormat = "dd/mm" * .HorizontalAlignment = xlGeneral * .VerticalAlignment = xlBottom * .WrapText = False * .Orientation = -90 * .AddIndent = False * .IndentLevel = 0 * .ShrinkToFit = False * .ReadingOrder = xlContext * .MergeCells = False * End With * With GanttRange.Font * .Name = "Arial" * .FontStyle = "Regular" * .Size = 8 * .Strikethrough = False * .Superscript = False * .Subscript = False * .OutlineFont = False * .Shadow = False * .Underline = xlUnderlineStyleNone * .ColorIndex= xlAutomatic * End With * With GanttRange * .Interior.ColorIndex= 3 * .Borders(xlDiagonalDown).LineStyle = xlNone * .Borders(xlDiagonalUp).LineStyle = xlNone * With .Borders(xlEdgeLeft) * .LineStyle = xlContinuous * .Weight = xlThin * .ColorIndex= xlAutomatic * End With * With .Borders(xlEdgeTop) * .LineStyle = xlContinuous * .Weight = xlThin * .ColorIndex= xlAutomatic * End With * With .Borders(xlEdgeBottom) * .LineStyle = xlContinuous * .Weight = xlThin * .ColorIndex= xlAutomatic * End With * With .Borders(xlEdgeRight) * .LineStyle = xlContinuous * .Weight = xlThin * .ColorIndex= xlAutomatic * End With * .Borders(xlInsideVertical).LineStyle = xlNone * End With * 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, Fantastic work - code is very nearly perfect!!! The only issue I've encountered is that for the first promo in Row 2, the code seems to using the start date for the event on Row 3, and the end date of the entire date range (i.e. as per the sample event data I gave you, Mar22 is shown as being between 05/03/2010 and 16/04/2010). The code is perfect for subsequent rows however? Also, is there a way to evaluate the event list in column A, and if the event description contains the word BULK, set .Interior.ColorIndex = 6? Thanks again!! Cheers Chris |
Select contiguous cells by ActiveCell.Interior.ColorIndex and applyborders
I added the feature for the BULK color to be yellow. I don't know where you are gettng the dates for the 1st row. I looked at the original code and thought you wanted the 1st row to be the minimum date in column b and the max date in Column C. the dates you are asking for aren't in the data you provided so I don't know where to get these dates from. VBA Code: -------------------- Enum DateState findmindate findmaxdate End Enum Sub Gantt_Chart() Application.ScreenUpdating = False Dim mindate As Date Dim maxdate As Date Dim columnoffset As Integer Dim task As Variant Dim colcount As Integer Dim daterange As Range Dim firstdate As Range Dim frequency As Integer Dim GanttStart As Range Dim HeaderDates As Range Dim lastcol As Integer Dim lastdate As Range Dim lastrow As Integer Dim startrow As Integer Dim startcolumn As Integer Dim startdate As Date Dim startdatestr As String Dim timeperiod As Integer startrow = 1 'Change this as necessary startcolumn = 1 'Where to start the gantt chart ganttcolumnoffset = 3 startdatestr = "Jan-4-2010" startdate = DateValue(startdatestr) frequency = 7 'Could be 1 for weekly chart timeperiod = 52 'clear chart area Range(Cells(startrow, startcolumn + ganttcolumnoffset), _ Cells(Rows.Count, Columns.Count)).Delete 'create date headings in row 1 colcount = startcolumn + ganttcolumnoffset For timecount = 0 To (timeperiod - 1) Cells(startrow, colcount) = startdate + (frequency * timecount) colcount = colcount + 1 Next timecount Set firstdate = Cells(startrow, startcolumn + ganttcolumnoffset) Set lastdate = firstdate.End(xlToRight) Set daterange = Range(firstdate, lastdate) daterange.EntireColumn.AutoFit daterange.NumberFormat = "mm/dd/yy" lastrow = Cells(startrow + 2, startcolumn).End(xlDown).Row Set mindaterange = _ Range(Cells(startrow + 2, startcolumn + 1), _ Cells(lastrow, startcolumn + 1)) Set maxdaterange = _ Range(Cells(startrow + 2, startcolumn + 2), _ Cells(lastrow, startcolumn + 2)) 'create main task chart mindate = WorksheetFunction.Min(mindaterange) maxdate = WorksheetFunction.Max(maxdaterange) minheaderdatecolumn = daterange.Column State = DateState.findmindate For Each cell In daterange Select Case State Case DateState.findmindate If cell.Offset(0, 1) <= mindate Then minheaderdatecolumn = minheaderdatecolumn + 1 Else Datecount = mindate Cells(startrow + 1, minheaderdatecolumn) = Datecount maxheaderdatecolumn = minheaderdatecolumn State = DateState.findmaxdate End If Case DateState.findmaxdate If cell <= maxdate Then Datecount = Datecount + frequency maxheaderdatecolumn = maxheaderdatecolumn + 1 Cells(startrow + 1, maxheaderdatecolumn) = Datecount Else Exit For End If End Select Next cell If InStr(UCase(Range("A" & (startrow + 2))), "BULK") 0 Then mycolor = 6 Else mycolor = 3 End If Call makechart(startrow + 1, minheaderdatecolumn, _ maxheaderdatecolumn, mycolor) 'create chart for each row For RowCount = (startrow + 2) To lastrow mindate = Cells(RowCount, startcolumn + 1) maxdate = Cells(RowCount, startcolumn + 2) minheaderdatecolumn = daterange.Column State = DateState.findmindate For Each cell In daterange Select Case State Case DateState.findmindate If cell.Offset(0, 1) <= mindate Then minheaderdatecolumn = minheaderdatecolumn + 1 Else Datecount = mindate Cells(RowCount, minheaderdatecolumn) = Datecount maxheaderdatecolumn = minheaderdatecolumn State = DateState.findmaxdate End If Case DateState.findmaxdate If cell <= maxdate Then Datecount = Datecount + frequency maxheaderdatecolumn = maxheaderdatecolumn + 1 Cells(RowCount, maxheaderdatecolumn) = Datecount Else Exit For End If End Select Next cell If InStr(UCase(Range("A" & RowCount)), "BULK") 0 Then mycolor = 6 Else mycolor = 3 End If Call makechart(RowCount, minheaderdatecolumn, _ maxheaderdatecolumn, mycolor) Next RowCount End Sub Sub makechart(ByVal myrow As Integer, _ ByVal startcol As Integer, ByVal endcol As Integer, _ ByVal mycolor As Integer) Set GanttRange = Range(Cells(myrow, startcol), _ Cells(myrow, endcol)) 'format dates With GanttRange .Interior.ColorIndex = mycolor .NumberFormat = "dd/mm" .HorizontalAlignment = xlGeneral .VerticalAlignment = xlBottom .WrapText = False .Orientation = -90 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With With GanttRange.Font .Name = "Arial" .FontStyle = "Regular" .Size = 8 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic End With With GanttRange .Borders(xlDiagonalDown).LineStyle = xlNone .Borders(xlDiagonalUp).LineStyle = xlNone With .Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With .Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With .Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With .Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With .Borders(xlInsideVertical).LineStyle = xlNone End With 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 |
Select contiguous cells by ActiveCell.Interior.ColorIndex andapplyborders
On Mar 15, 11:14*pm, joel wrote:
I added the feature for the BULK color to be yellow. *I don't know where you are gettng the dates for the 1st row. *I looked at the original code and thought you wanted the 1st row to be the minimum date in column b and the max date in Column C. *the dates you are asking for aren't in the data you provided so I don't know where to get these dates from. VBA Code: -------------------- Enum DateState * findmindate * findmaxdate * End Enum * Sub Gantt_Chart() * Application.ScreenUpdating = False * Dim mindate As Date * Dim maxdate As Date * Dim columnoffset As Integer * Dim task As Variant * Dim colcount As Integer * Dim daterange As Range * Dim firstdate As Range * Dim frequency As Integer * Dim GanttStart As Range * Dim HeaderDates As Range * Dim lastcol As Integer * Dim lastdate As Range * Dim lastrow As Integer * Dim startrow As Integer * Dim startcolumn As Integer * Dim startdate As Date * Dim startdatestr As String * Dim timeperiod As Integer * startrow = 1 'Change this as necessary * startcolumn = 1 'Where to start the gantt chart * ganttcolumnoffset = 3 * startdatestr = "Jan-4-2010" * startdate = DateValue(startdatestr) * frequency = 7 'Could be 1 for weekly chart * timeperiod = 52 * 'clear chart area * Range(Cells(startrow, startcolumn + ganttcolumnoffset), _ * Cells(Rows.Count, Columns.Count)).Delete * 'create date headings in row 1 * colcount = startcolumn + ganttcolumnoffset * For timecount = 0 To (timeperiod - 1) * Cells(startrow, colcount) = startdate + (frequency * timecount) * colcount = colcount + 1 * Next timecount * Set firstdate = Cells(startrow, startcolumn + ganttcolumnoffset) * Set lastdate = firstdate.End(xlToRight) * Set daterange = Range(firstdate, lastdate) * daterange.EntireColumn.AutoFit * daterange.NumberFormat = "mm/dd/yy" * lastrow = Cells(startrow + 2, startcolumn).End(xlDown).Row * Set mindaterange = _ * Range(Cells(startrow + 2, startcolumn + 1), _ * Cells(lastrow, startcolumn + 1)) * Set maxdaterange = _ * Range(Cells(startrow + 2, startcolumn + 2), _ * Cells(lastrow, startcolumn + 2)) * 'create main task chart * mindate = WorksheetFunction.Min(mindaterange) * maxdate = WorksheetFunction.Max(maxdaterange) * minheaderdatecolumn = daterange.Column * State = DateState.findmindate * For Each cell In daterange * Select Case State * Case DateState.findmindate * If cell.Offset(0, 1) <= mindate Then * minheaderdatecolumn = minheaderdatecolumn + 1 * Else * Datecount = mindate * Cells(startrow + 1, minheaderdatecolumn) = Datecount * maxheaderdatecolumn = minheaderdatecolumn * State = DateState.findmaxdate * End If * Case DateState.findmaxdate * If cell <= maxdate Then * Datecount = Datecount + frequency * maxheaderdatecolumn = maxheaderdatecolumn + 1 * Cells(startrow + 1, maxheaderdatecolumn) = Datecount * Else * Exit For * End If * End Select * Next cell * If InStr(UCase(Range("A" & (startrow + 2))), "BULK") 0 Then * mycolor = 6 * Else * mycolor = 3 * End If * Call makechart(startrow + 1, minheaderdatecolumn, _ * maxheaderdatecolumn, mycolor) * 'create chart for each row * For RowCount = (startrow + 2) To lastrow * mindate = Cells(RowCount, startcolumn + 1) * maxdate = Cells(RowCount, startcolumn + 2) * minheaderdatecolumn = daterange.Column * State = DateState.findmindate * For Each cell In daterange * Select Case State * Case DateState.findmindate * If cell.Offset(0, 1) <= mindate Then * minheaderdatecolumn = minheaderdatecolumn + 1 * Else * Datecount = mindate * Cells(RowCount, minheaderdatecolumn) = Datecount * maxheaderdatecolumn = minheaderdatecolumn * State = DateState.findmaxdate * End If * Case DateState.findmaxdate * If cell <= maxdate Then * Datecount = Datecount + frequency * maxheaderdatecolumn = maxheaderdatecolumn + 1 * Cells(RowCount, maxheaderdatecolumn) = Datecount * Else * Exit For * End If * End Select * Next cell * If InStr(UCase(Range("A" & RowCount)), "BULK") 0 Then * mycolor = 6 * Else * mycolor = 3 * End If * Call makechart(RowCount, minheaderdatecolumn, _ * maxheaderdatecolumn, mycolor) * Next RowCount * End Sub * Sub makechart(ByVal myrow As Integer, _ * ByVal startcol As Integer, ByVal endcol As Integer, _ * ByVal mycolor As Integer) * Set GanttRange = Range(Cells(myrow, startcol), _ * Cells(myrow, endcol)) * 'format dates * With GanttRange * .Interior.ColorIndex = mycolor * .NumberFormat = "dd/mm" * .HorizontalAlignment = xlGeneral * .VerticalAlignment = xlBottom * .WrapText = False * .Orientation = -90 * .AddIndent = False * .IndentLevel = 0 * .ShrinkToFit = False * .ReadingOrder = xlContext * .MergeCells = False * End With * With GanttRange.Font * .Name = "Arial" * .FontStyle = "Regular" * .Size = 8 * .Strikethrough = False * .Superscript = False * .Subscript = False * .OutlineFont = False * .Shadow = False * .Underline = xlUnderlineStyleNone * .ColorIndex = xlAutomatic * End With * With GanttRange * .Borders(xlDiagonalDown).LineStyle = xlNone * .Borders(xlDiagonalUp).LineStyle = xlNone * With .Borders(xlEdgeLeft) * .LineStyle = xlContinuous * .Weight = xlThin * .ColorIndex = xlAutomatic * End With * With .Borders(xlEdgeTop) * .LineStyle = xlContinuous * .Weight = xlThin * .ColorIndex = xlAutomatic * End With * With .Borders(xlEdgeBottom) * .LineStyle = xlContinuous * .Weight = xlThin * .ColorIndex = xlAutomatic * End With * With .Borders(xlEdgeRight) * .LineStyle = xlContinuous * .Weight = xlThin * .ColorIndex = xlAutomatic * End With * .Borders(xlInsideVertical).LineStyle = xlNone * End With * 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 adding the additional color for BULK - looks great. Sorry if I didn't explain the date issue correctly: In the below data (which is part of the actual data I'm using), the column headings are in A1:C1. The mindate/maxdate of the range as below would be 01/02/2010 (in cell B2) and 30/09/2010 (in cell C9). The date headings for the range starts in D1 and runs to wherever your code specifies. All of this is working as it should, but as per the examples below, the yellow bar for the first event under the headings (in row 2) FB1905 runs from 08/02/2010 to 30/09/2010, where as it should run from 01/02/2010 to 14/03/2010. The next event however (FB1906) is showing correctly from 08/02/2010 to 21/03/2010 as are all the other subsequent ones? Promo start finish FB1905 - MEGA FB1905 BULK MERCH 1 10 1/02/2010 14/03/2010 FB1906 - MEGA FB1906 BULK MERCH 2 10 8/02/2010 21/03/2010 FB1907 - MEGA FB1907 BULK MERCH 3 10 15/02/2010 28/03/2010 FB1170 - FB1170 HOUSEWASH BRUSH BUY OPP 22/02/2010 31/03/2010 FEB500 - FEB500 HOUSEWASH BRUSH BUY OPP22/02/2010 31/03/2010 FB1908 - MEGA FB1908 BULK MERCH 4 10 22/02/2010 4/04/2010 MAR298 - MAR298 TRADE MAILER 10 1/03/2010 31/03/2010 AU1173 - AU1173 MEGA ODOOR FURN IND 10 8/09/2010 30/09/2010 So essentially, the code is perfect other than for that first event contained in Row 2. Hope this makes sense!! Also, just out of interest, what does the Enum/End Enum routine at the start of the code do? I've never come across this before? Cheers Chris |
Select contiguous cells by ActiveCell.Interior.ColorIndex andapplyborders
On Mar 16, 11:23*am, nofam wrote:
On Mar 15, 11:14*pm, joel wrote: I added the feature for the BULK color to be yellow. *I don't know where you are gettng the dates for the 1st row. *I looked at the original code and thought you wanted the 1st row to be the minimum date in column b and the max date in Column C. *the dates you are asking for aren't in the data you provided so I don't know where to get these dates from. VBA Code: -------------------- Enum DateState * findmindate * findmaxdate * End Enum * Sub Gantt_Chart() * Application.ScreenUpdating = False * Dim mindate As Date * Dim maxdate As Date * Dim columnoffset As Integer * Dim task As Variant * Dim colcount As Integer * Dim daterange As Range * Dim firstdate As Range * Dim frequency As Integer * Dim GanttStart As Range * Dim HeaderDates As Range * Dim lastcol As Integer * Dim lastdate As Range * Dim lastrow As Integer * Dim startrow As Integer * Dim startcolumn As Integer * Dim startdate As Date * Dim startdatestr As String * Dim timeperiod As Integer * startrow = 1 'Change this as necessary * startcolumn = 1 'Where to start the gantt chart * ganttcolumnoffset = 3 * startdatestr = "Jan-4-2010" * startdate = DateValue(startdatestr) * frequency = 7 'Could be 1 for weekly chart * timeperiod = 52 * 'clear chart area * Range(Cells(startrow, startcolumn + ganttcolumnoffset), _ * Cells(Rows.Count, Columns.Count)).Delete * 'create date headings in row 1 * colcount = startcolumn + ganttcolumnoffset * For timecount = 0 To (timeperiod - 1) * Cells(startrow, colcount) = startdate + (frequency * timecount) * colcount = colcount + 1 * Next timecount * Set firstdate = Cells(startrow, startcolumn + ganttcolumnoffset) * Set lastdate = firstdate.End(xlToRight) * Set daterange = Range(firstdate, lastdate) * daterange.EntireColumn.AutoFit * daterange.NumberFormat = "mm/dd/yy" * lastrow = Cells(startrow + 2, startcolumn).End(xlDown).Row * Set mindaterange = _ * Range(Cells(startrow + 2, startcolumn + 1), _ * Cells(lastrow, startcolumn + 1)) * Set maxdaterange = _ * Range(Cells(startrow + 2, startcolumn + 2), _ * Cells(lastrow, startcolumn + 2)) * 'create main task chart * mindate = WorksheetFunction.Min(mindaterange) * maxdate = WorksheetFunction.Max(maxdaterange) * minheaderdatecolumn = daterange.Column * State = DateState.findmindate * For Each cell In daterange * Select Case State * Case DateState.findmindate * If cell.Offset(0, 1) <= mindate Then * minheaderdatecolumn = minheaderdatecolumn + 1 * Else * Datecount = mindate * Cells(startrow + 1, minheaderdatecolumn) = Datecount * maxheaderdatecolumn = minheaderdatecolumn * State = DateState.findmaxdate * End If * Case DateState.findmaxdate * If cell <= maxdate Then * Datecount = Datecount + frequency * maxheaderdatecolumn = maxheaderdatecolumn + 1 * Cells(startrow + 1, maxheaderdatecolumn) = Datecount * Else * Exit For * End If * End Select * Next cell * If InStr(UCase(Range("A" & (startrow + 2))), "BULK") 0 Then * mycolor = 6 * Else * mycolor = 3 * End If * Call makechart(startrow + 1, minheaderdatecolumn, _ * maxheaderdatecolumn, mycolor) * 'create chart for each row * For RowCount = (startrow + 2) To lastrow * mindate = Cells(RowCount, startcolumn + 1) * maxdate = Cells(RowCount, startcolumn + 2) * minheaderdatecolumn = daterange.Column * State = DateState.findmindate * For Each cell In daterange * Select Case State * Case DateState.findmindate * If cell.Offset(0, 1) <= mindate Then * minheaderdatecolumn = minheaderdatecolumn + 1 * Else * Datecount = mindate * Cells(RowCount, minheaderdatecolumn) = Datecount * maxheaderdatecolumn = minheaderdatecolumn * State = DateState.findmaxdate * End If * Case DateState.findmaxdate * If cell <= maxdate Then * Datecount = Datecount + frequency * maxheaderdatecolumn = maxheaderdatecolumn + 1 * Cells(RowCount, maxheaderdatecolumn) = Datecount * Else * Exit For * End If * End Select * Next cell * If InStr(UCase(Range("A" & RowCount)), "BULK") 0 Then * mycolor = 6 * Else * mycolor = 3 * End If * Call makechart(RowCount, minheaderdatecolumn, _ * maxheaderdatecolumn, mycolor) * Next RowCount * End Sub * Sub makechart(ByVal myrow As Integer, _ * ByVal startcol As Integer, ByVal endcol As Integer, _ * ByVal mycolor As Integer) * Set GanttRange = Range(Cells(myrow, startcol), _ * Cells(myrow, endcol)) * 'format dates * With GanttRange * .Interior.ColorIndex = mycolor * .NumberFormat = "dd/mm" * .HorizontalAlignment = xlGeneral * .VerticalAlignment = xlBottom * .WrapText = False * .Orientation = -90 * .AddIndent = False * .IndentLevel = 0 * .ShrinkToFit = False * .ReadingOrder = xlContext * .MergeCells = False * End With * With GanttRange.Font * .Name = "Arial" * .FontStyle = "Regular" * .Size = 8 * .Strikethrough = False * .Superscript = False * .Subscript = False * .OutlineFont = False * .Shadow = False * .Underline = xlUnderlineStyleNone * .ColorIndex = xlAutomatic * End With * With GanttRange * .Borders(xlDiagonalDown).LineStyle = xlNone * .Borders(xlDiagonalUp).LineStyle = xlNone * With .Borders(xlEdgeLeft) * .LineStyle = xlContinuous * .Weight = xlThin * .ColorIndex = xlAutomatic * End With * With .Borders(xlEdgeTop) * .LineStyle = xlContinuous * .Weight = xlThin * .ColorIndex = xlAutomatic * End With * With .Borders(xlEdgeBottom) * .LineStyle = xlContinuous * .Weight = xlThin * .ColorIndex = xlAutomatic * End With * With .Borders(xlEdgeRight) * .LineStyle = xlContinuous * .Weight = xlThin * .ColorIndex = xlAutomatic * End With * .Borders(xlInsideVertical).LineStyle = xlNone * End With * 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 adding the additional color for BULK - looks great. *Sorry if I didn't explain the date issue correctly: In the below data (which is part of the actual data I'm using), the column headings are in A1:C1. *The mindate/maxdate of the range as below would be 01/02/2010 (in cell B2) and 30/09/2010 (in cell C9). The date headings for the range starts in D1 and runs to wherever your code specifies. All of this is working as it should, but as per the examples below, the yellow bar for the first event under the headings (in row 2) FB1905 runs from 08/02/2010 to 30/09/2010, where as it should run from 01/02/2010 to 14/03/2010. The next event however (FB1906) is showing correctly from 08/02/2010 to 21/03/2010 as are all the other subsequent ones? Promo start * * * * * finish FB1905 - MEGA FB1905 BULK MERCH 1 *10 * * * * 1/02/2010 14/03/2010 FB1906 - MEGA FB1906 BULK MERCH 2 *10 * * * * 8/02/2010 21/03/2010 FB1907 - MEGA FB1907 BULK MERCH 3 *10 * * * *15/02/2010 28/03/2010 FB1170 - FB1170 HOUSEWASH BRUSH BUY OPP 22/02/2010 * * *31/03/2010 FEB500 - FEB500 HOUSEWASH BRUSH BUY OPP22/02/2010 * * * 31/03/2010 FB1908 - MEGA FB1908 BULK MERCH 4 *10 * * * *22/02/2010 4/04/2010 MAR298 - MAR298 TRADE MAILER *10 * * * * * * * * * * 1/03/2010 *31/03/2010 AU1173 - AU1173 MEGA ODOOR FURN IND 10 * * * *8/09/2010 30/09/2010 So essentially, the code is perfect other than for that first event contained in Row 2. Hope this makes sense!! Also, just out of interest, what does the Enum/End Enum routine at the start of the code do? *I've never come across this before? Cheers Chris Hey, I've uploaded a copy of the workbook if you want to see what I mean as above: http://www.sendspace.com/file/rux5nq Cheers Chris |
Select contiguous cells by ActiveCell.Interior.ColorIndex and applyborders
I'm at work and the site where yo placed the workbook is blocked. I added a summarry bar at the top of the chart. If you start your dates at the 3rd row instead of the 2nd row it will fix the problem and add a summary bar at the top. -- 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 |
Select contiguous cells by ActiveCell.Interior.ColorIndex andapplyborders
On Mar 17, 12:10*am, joel wrote:
I'm at work and the site where yo placed the workbook is blocked. *I added a summarry bar at the top of the chart. *If you start your dates at the 3rd row instead of the 2nd row it will fix the problem and add a summary bar at the top. -- 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, Makes perfect sense now - sorry I didn't pick this up sooner. Have moved the dates down as you suggested and it works fine! Looking at the chart now it's working, the only other thing that would improve it is the addition of 'guide lines' to make it a little easier to read; i.e. for each event, have Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous added from the event name in Column A to the first date in the red/yellow bar - just makes it easier to track which event name relates to which bar when it's printed on an A1 page. Thanks again Chris |
All times are GMT +1. The time now is 05:49 PM. |
Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
ExcelBanter.com