Gantt chart style spreadsheet

[Fudge16]

Hello,

I am trying to get the name of the task to show in the gantt chart bar.

For example for task 1 I have a green bar between the dates 22/8/17 to 27/8/17. The dates are selected in Cell D60 and F60 using conditional formatting cells V59 (22/8/17) to AA59 (27/8/17) changes to green. If i change the dates in Cell D60 and F60 to 21/8/17 and 26/8/17 corresponding to cells U59 to Z59.

Here is where I am stuck;

I would like the name of the task i.e. task 1 to appear in the cell corresponding to the start date so in this example V59. However, I want this to move when the dates are changed i.e. to U59.

I cant get this to work so any help would be appreciated.

Also, I am new to this site. Is it possible to share the spreadsheet on here?

Thanks

 

[Fudge16]

Re: Help with Gantt chart style spreadsheet

Test on a copy of your workbook.

Sub Add_Labels()
  Dim firstcol As Long, lastcol As Long, cols As Long
  Dim TaskCell As Range, Found As Range
  
  Const FirstDateCol As String = "G"
  Const DateRow As Long = 56
  Const ColourRow As Long = 59
  
  firstcol = Columns(FirstDateCol).Column
  lastcol = Cells(DateRow, Columns.Count).End(xlToLeft).Column
  cols = lastcol - firstcol + 1
  Cells(ColourRow, firstcol).Resize(, cols).ClearContents
  For Each TaskCell In Range("C60", Range("C" & Rows.Count).End(xlUp))
    Set Found = Rows(DateRow).Find(What:=TaskCell.Offset(, 1).Value, LookIn:=xlFormulas, LookAt:=xlWhole)
    If Not Found Is Nothing Then Intersect(Found.EntireColumn, Rows(ColourRow)).Value = TaskCell.Value
  Next TaskCell
End Sub

Hi, Unfortunately this did not work it just seems to be clearing all the cells and not putting in any text. Would it be better if I sent you the spreadsheet?

 

[Peter_SSs]

Re: Help with Gantt chart style spreadsheet

Would it be better if I sent you the spreadsheet?

Perhaps you missed my last post (post #10 )?

 

[Fudge16]

Re: Help with Gantt chart style spreadsheet

Perhaps you missed my last post (post #10 )?

https://1drv.ms/x/s!Ag5HSdHV1N2maCkrgjHqp4jotuQ

Apologies my internet is very bad. I hope the link works...

 

[Peter_SSs]

Re: Help with Gantt chart style spreadsheet

Sorry, I had a few things wrong in that earlier code that hopefully are corrected here. Also, I didn't realise that your table on the sheet in question has about 10,000 rows, most of which are empty, in the sample at least.
So I'm now assuming that the tasks in column C from row 60 are listed without gaps. That is, this new code works down the column from C60 until it meets the first empty cell and stops.

Give this one a try

Sub Add_Labels_v2()
  Dim firstcol As Long, lastcol As Long, cols As Long, r As Long
  Dim TaskHeader As Range, Found As Range
  
  Const FirstDateCol As String = "G"
  Const DateRow As Long = 56
  Const ColourRow As Long = 59
  
  firstcol = Columns(FirstDateCol).Column
  lastcol = Cells(DateRow, Columns.Count).End(xlToLeft).Column
  cols = lastcol - firstcol + 1
  Cells(ColourRow, firstcol).Resize(, cols).ClearContents
  Set TaskHeader = Range("C" & ColourRow)
  r = 1
  Do Until Len(TaskHeader.Offset(r).Value) = 0
    Set Found = Rows(DateRow).Find(What:=Format(TaskHeader.Offset(r, 1).Value, "dd"), LookIn:=xlValues, LookAt:=xlPart)
    If Not Found Is Nothing Then Intersect(Found.EntireColumn, Rows(ColourRow)).Value = TaskHeader.Offset(r).Value
    r = r + 1
  Loop
End Sub

 

[Fudge16]

Re: Help with Gantt chart style spreadsheet

Sorry, I had a few things wrong in that earlier code that hopefully are corrected here. Also, I didn't realise that your table on the sheet in question has about 10,000 rows, most of which are empty, in the sample at least.
So I'm now assuming that the tasks in column C from row 60 are listed without gaps. That is, this new code works down the column from C60 until it meets the first empty cell and stops.

Give this one a try

Sub Add_Labels_v2()
  Dim firstcol As Long, lastcol As Long, cols As Long, r As Long
  Dim TaskHeader As Range, Found As Range
  
  Const FirstDateCol As String = "G"
  Const DateRow As Long = 56
  Const ColourRow As Long = 59
  
  firstcol = Columns(FirstDateCol).Column
  lastcol = Cells(DateRow, Columns.Count).End(xlToLeft).Column
  cols = lastcol - firstcol + 1
  Cells(ColourRow, firstcol).Resize(, cols).ClearContents
  Set TaskHeader = Range("C" & ColourRow)
  r = 1
  Do Until Len(TaskHeader.Offset(r).Value) = 0
    Set Found = Rows(DateRow).Find(What:=Format(TaskHeader.Offset(r, 1).Value, "dd"), LookIn:=xlValues, LookAt:=xlPart)
    If Not Found Is Nothing Then Intersect(Found.EntireColumn, Rows(ColourRow)).Value = TaskHeader.Offset(r).Value
    r = r + 1
  Loop
End Sub

Screenshot of tool planner 2 - Free Image Hosting

Hi Peter, again thanks for your quick response and it seems you have nearly solved the problem.

I have attached a screenshot of the results from your code and I have some feedback that will make it how I need it.

1) It is not recognizing the month therefore it just puts it in the cell that has the same day. I believe if I inserted a row into 55 with dates that match column D, formatting the code could match to this so that the exact date will be found. I would then hide this row so I can keep the cell sizes the same for the current formatting.
2) In column C there will be blank spaces inbetween therefore the code should not stop when it finds a blank.
3) As can be seen in the screenshot rows 59-99 are grouped and have its own colored bar (row 59). Rows 101-141 are also grouped together and has its own colored bar section Row (101) the colored bars are pulled from rows 102-141. I would need the text to pull into row 101 from 102 -141 like it does in row 59 from 60-99.

Again, thank you very much for your time and effort. Let me know if you need more information.

Best regards

 

[Peter_SSs]

Re: Help with Gantt chart style spreadsheet

Best not to quote my whole post unless there is a specific reason to do so. It tends to make your post and the whole thread harder to read/review/navigate. Just quote any small part(s) that you want to refer specifically to - as I have mini-quoted you below.

1) It is not recognizing the month ..

Yes, another careless error on my part! But should be no need for another row of dates.

2) In column C there will be blank spaces inbetween therefore the code should not stop when it finds a blank.

OK, noted. I was trying to avoid having to process 10,000 rows but hopefully my new approach will avoid having to do that - unless you will actually have that many rows of data.

3) As can be seen in the screenshot rows 59-99 are grouped and have its own colored bar (row 59). Rows 101-141 are also grouped together and has its own colored bar section Row (101) ..

OK, noted.

Try v3

Sub Add_Labels_v3()
  Dim FirstCol As Long, LastCol As Long, Cols As Long, r As Long, LastRow As Long, c As Long, ColourRow As Long
  Dim StartDate As Date
  
  Const FirstDateCol As String = "G"
  Const DateRow As Long = 56
  Const FirstColourRow As Long = 59
  
  FirstCol = Columns(FirstDateCol).Column
  LastCol = Cells(DateRow, Columns.Count).End(xlToLeft).Column
  Cols = LastCol - FirstCol + 1
  LastRow = Columns("C").Find(What:="?*", After:=Range("C1"), LookIn:=xlValues, SearchDirection:=xlPrevious).Row
  Application.ScreenUpdating = False
  For r = FirstColourRow To LastRow
    Select Case Rows(r).OutlineLevel
      Case 1
        ColourRow = r
        If Len(Range("C" & r).Value) > 0 Then Range(FirstDateCol & r).Resize(, Cols).ClearContents
      Case 2
        If Len(Range("C" & r).Value) > 0 Then
          StartDate = Range("D" & r).Value
          c = LastCol
          Do Until (Cells(DateRow - 1, c).Value <= StartDate And Cells(DateRow - 1, c).Value > 0) Or c < FirstCol
            c = c - 1
          Loop
          If c >= FirstCol Then Cells(ColourRow, c + Day(StartDate) - Day(Cells(DateRow - 1, c).Value)).Value = Range("C" & r).Value
        End If
    End Select
  Next r
  Application.ScreenUpdating = True
End Sub

 

[Fudge16]

Re: Help with Gantt chart style spreadsheet

Hi Peter,

This is fantastic! Thank you so much for your effort towards helping me.

I have noticed one tiny issue though. Please refer to the images attached

Screenshot of tool planner 3 - Free Image Hosting - Working correctly

Screenshot of tool planner 4 - Free Image Hosting - Slight error

In the slight error picture I have changed the date in F53 from the 4th to 5th of July. This changes the date in cell G56. (This also occurs when I change F53 from 28/29th of June.)

For some reason the contents in row D65 is then entered a month early. The text "bhj" now located in cell AL59 instead of BQ59.

I tried this on other cells but a problem only occurred for row 65

 

[Peter_SSs]

Re: Help with Gantt chart style spreadsheet

For some reason the contents in row D65 is then entered a month early.

That is still me making mistakes but hopefully we are closing in on the solution.

Try making this replacement

<del>If c >= FirstCol Then Cells(ColourRow, c + Day(StartDate) - Day(Cells(DateRow - 1, c).Value)).Value = Range("C" & r).Value</del>
If c >= FirstCol Then Cells(ColourRow, c + StartDate - Cells(DateRow - 1, c).Value).Value = Range("C" & r).Value

 

[Fudge16]

Re: Help with Gantt chart style spreadsheet

Try making this replacement

<del>If c >= FirstCol Then Cells(ColourRow, c + Day(StartDate) - Day(Cells(DateRow - 1, c).Value)).Value = Range("C" & r).Value</del>
If c >= FirstCol Then Cells(ColourRow, c + StartDate - Cells(DateRow - 1, c).Value).Value = Range("C" & r).Value

[/QUOTE]

Hi Peter, It did the trick excellently!

Here is how it looks.
Screenshot of tool planner 5 - Free Image Hosting (1)
Screenshot of tool planner 6 - Free Image Hosting (2)

The only problem I can see is that the very last row (983) shown in blue is not showing the text (1). If I add more rows then apply the code this row will start to fill with text but still the new last row with color will not show the text (2).

An easy fix is I just have one more group of rows that I do not need. What are your thoughts Peter?

 

[Peter_SSs]

Re: Help with Gantt chart style spreadsheet

The only problem I can see is that the very last row (983) shown in blue is not showing the text (1).

In your previous screen shots the row groupings were expanded. In this image they are collapsed and I think that is the problem. Try this version. New or moved code lines highlighted.

Sub Add_Labels_v4()
  Dim FirstCol As Long, LastCol As Long, Cols As Long, r As Long, LastRow As Long, c As Long, ColourRow As Long
  Dim StartDate As Date
  
  Const FirstDateCol As String = "G"
  Const DateRow As Long = 56
  Const FirstColourRow As Long = 59
  
  Application.ScreenUpdating = False
  ActiveSheet.Outline.ShowLevels RowLevels:=2
  FirstCol = Columns(FirstDateCol).Column
  LastCol = Cells(DateRow, Columns.Count).End(xlToLeft).Column
  Cols = LastCol - FirstCol + 1
  LastRow = Columns("C").Find(What:="?*", After:=Range("C1"), LookIn:=xlValues, SearchDirection:=xlPrevious).Row
  For r = FirstColourRow To LastRow
    Select Case Rows(r).OutlineLevel
      Case 1
        ColourRow = r
        If Len(Range("C" & r).Value) > 0 Then Range(FirstDateCol & r).Resize(, Cols).ClearContents
      Case 2
        If Len(Range("C" & r).Value) > 0 Then
          StartDate = Range("D" & r).Value
          c = LastCol
          Do Until (Cells(DateRow - 1, c).Value <= StartDate And Cells(DateRow - 1, c).Value > 0) Or c < FirstCol
            c = c - 1
          Loop
          If c >= FirstCol Then Cells(ColourRow, c + StartDate - Cells(DateRow - 1, c).Value).Value = Range("C" & r).Value
        End If
    End Select
  Next r
  ActiveSheet.Outline.ShowLevels RowLevels:=1
  Application.ScreenUpdating = True
End Sub