List cells based on text macro

[garyi]

Hello folks

I have created a spreadsheet which has a row listing all dates in 2019.
Under this we will add rows for various contracts so we can colour the cells based on various dates needed for the contract over the year. There are 7 date specific things that are in a drop down format so it will always be specific text.
This goes across the whole year so is a bit unwieldy to review.

So what I want to do is have macro that will look through that range of cells for this specific text, for instance 'start date' and list that information on another tab, with the date from the date row above alongside it.

I hope that makes sense. It does not actually have to be a macro but if anyone can give me a nudge in the right direction that would be appreciated.

 

[garyi]

Thank you for your continued assistance.

I get this:

https://www.dropbox.com/s/6dg1tz7o02sfayw/Screenshot 2018-07-22 at 08.49.12.png?dl=0


Which in essence is my sheet but turned around?

 

[Yongle]

Good - it is finding the dates
Will update later today for you

 

[garyi]

I have no idea what I have done with my date line, I could just redo the whole sheet from scratch there is not a lot too it at the moment.

 

[Yongle]

Ok - try this

This is what I get:

	Example Contract1	Example Contract2	Example Contract3	Example Contract4	Example Contract5
1st App	01/01/2019	02/01/2019	03/01/2019	04/01/2019	05/01/2019
pre qual	02/01/2019	03/01/2019	04/01/2019	05/01/2019	06/01/2019
site visit	03/01/2019	04/01/2019	05/01/2019	06/01/2019	07/01/2019
tender sub	04/01/2019	05/01/2019	06/01/2019	07/01/2019	08/01/2019
shortlist	05/01/2019	06/01/2019	07/01/2019	08/01/2019	09/01/2019
presentation	06/01/2019	07/01/2019	08/01/2019	09/01/2019	10/01/2019
decision	07/01/2019	08/01/2019	09/01/2019	10/01/2019	11/01/2019
award	08/01/2019	09/01/2019	10/01/2019	11/01/2019	12/01/2019
start date	09/01/2019	13/01/2019	11/01/2019	14/01/2019	15/01/2019

<tbody>
</tbody>

If you have any problems look in Immediate Widow (generated by Debug.Print Contract, Milestone, c, r )
This is what I get for the first contract (Contract Name, milestone value from cell, contract column in new sheet, milestone row in new sheet):
Example Contract1 1st App 2 2
Example Contract1 pre qual 2 3
Example Contract1 site visit 2 4
Example Contract1 tender sub 2 5
Example Contract1 shortlist 2 6
Example Contract1 presentation 2 7
Example Contract1 decision 2 8
Example Contract1 award 2 9
Example Contract1 start date 2 10

Sub CreateTable5()
Const MySheet = "Data"
Dim Main As Worksheet, NewSheet As Worksheet
Dim Contracts As Range, DateRng As Range, Contract As Range, cel As Range
Dim Milestones As Variant, Milestone As Variant, c As Long, r As Long
Set Main = Sheets(MySheet)
Set NewSheet = Sheets.Add(after:=Main)
Set Contracts = Main.Range("B10", Main.Range("B" & Rows.Count).End(xlUp))
Set DateRng = Main.Range("F8", Main.Cells(8, Columns.Count).End(xlToLeft))
'add column headers
    Contracts.Copy
    NewSheet.Range("B1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
'add row headers
    Milestones = Split(Main.Range("F10").Validation.Formula1, ",")
    NewSheet.Range("A2").Resize(UBound(Milestones) + 1).Value = WorksheetFunction.Transpose(Milestones)
'add values
    For Each Contract In Contracts
        For Each cel In Main.Cells(Contract.Row, "F").Resize(, DateRng.Columns.Count)
            Milestone = cel.Value
            If Milestone <> "" Then
                On Error Resume Next
                c = NewSheet.Range("1:1").Find(Contract).Column
                r = NewSheet.Range("A:A").Find(Milestone).Row
                [COLOR=#ff0000]Debug.Print Contract, Milestone, c, r[/COLOR]
                NewSheet.Cells(r, c) = DateValue(Main.Cells(8, cel.Column))
            End If
        Next cel
    Next Contract
'formatting
    With NewSheet.Range("A1").CurrentRegion
        .Rows(1).Font.Bold = True
        .Rows(1).WrapText = True
        .Columns(1).Font.Bold = True
        .ColumnWidth = 15
        .HorizontalAlignment = xlCenter
        .Borders.LineStyle = xlContinuous
    End With
End Sub

 

[garyi]

It works!

Thank you so much for your help, it does exactly what I need.

 

[Yongle]

Excellent, thanks for feedback
You can delete Debug.Print line

 

[garyi]

Good morning Yongle, or anyone else that can help!

I need to make some adjustments.

I seem to recall there is a way to put the macro so that when you select the worksheet it automatically does it?

Or at least I would like to have just one work sheet where this data populates at the moment it creates a new sheet everytime, or perhaps it could delete that sheet first?

I would also like to use the alternate layout, or at least my colleagues would!

Any help you can offer would be appreciated.