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.

 

[Yongle]

I amended the 2 constant values to reflect the layout of your worksheet and VBA generated expected results
- hopefully this makes everything easy to follow....

Sheet "Data" amended to the same layout as in your picture...
- where 1st date is in C8 and first contract in B10

Col A	Col B	Col C	etc
	Prorspective client	T	W	T	F	S	S	M	T	W
row 8	01-01	02-01	03-01	04-01	05-01	06-01	07-01	08-01	09-01
row 10	Example Contract1	1st App	pre qual	site visit	tender sub	shortlist	presentation	decision	award	start date
etc	Example Contract2		1st App	pre qual	site visit	tender sub	shortlist	presentation	decision	award
	Example Contract3			1st App	pre qual	site visit	tender sub	shortlist	presentation	decision
	Example Contract4				1st App	pre qual	site visit	tender sub	shortlist	presentation
	Example Contract5					1st App	pre qual	site visit	tender sub	shortlist

<tbody>
</tbody>

Result tables:

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

<tbody>
</tbody>

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

<tbody>
</tbody>

VBA:

Private Sub AddFormat(UsedRng As Range, DateFormat As Range)
    With UsedRng
        .Rows(1).Font.Bold = True
        .Columns(1).Font.Bold = True
        .ColumnWidth = 15
        .HorizontalAlignment = xlCenter
        .Borders.LineStyle = xlContinuous
        .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1).NumberFormat = DateFormat.NumberFormat
    End With
End Sub

Sub [COLOR=#ff0000]CreateTableA[/COLOR]()
Const Date1 = "[COLOR=#000080]C8[/COLOR]"                  '= ref of first cell with a date
Const Contract1 = "[COLOR=#000080]B10[/COLOR]"             '= ref of first cell with contract name (or reference)
Const MySheet = "Data"       '= name of sheet containing data

Dim Main As Worksheet, NewSheet As Worksheet, Milestones As Variant, Milestone As Variant
Dim DateRng As Range, ContractRng As Range, TextRng As Range, Contract As Range, MilestoneRng As Range, NewContractRng As Range
Dim ContractRow As Range, DateRow As Long, DateCol As Long
Set Main = Sheets(MySheet)
'set first cells and get validation list
    Set DateRng = Main.Range(Date1)
    DateRow = DateRng.Row
    Set ContractRng = Main.Range(Contract1)
    Set TextRng = Main.Cells(ContractRng.Row, DateRng.Column)
    Milestones = Split(TextRng.Validation.Formula1, ",")
'expanded to set complete range
    Set ContractRng = Range(ContractRng, Main.Cells(Rows.Count, ContractRng.Column).End(xlUp))
'add new sheet and create outline
    Application.ScreenUpdating = False
    Set NewSheet = Sheets.Add(after:=Main)
        With NewSheet
            Set MilestoneRng = .Range("A2").Resize(UBound(Milestones) + 1)
                MilestoneRng.Value = WorksheetFunction.Transpose(Milestones)
        
            Set NewContractRng = .Range("B1").Resize(, ContractRng.Rows.Count)
                ContractRng.Copy: NewContractRng.PasteSpecial Paste:=xlPasteValues, Transpose:=True
            Call AddFormat(.UsedRange, DateRng)
        End With
'enter data in cells
    For Each Contract In NewContractRng
        On Error Resume Next
        Set ContractRow = Main.Rows(ContractRng.Find(what:=Contract.Value, LookIn:=xlValues, lookat:=xlWhole).Row)
        If Not ContractRow Is Nothing Then
            For Each Milestone In MilestoneRng
                On Error Resume Next
                DateCol = ContractRow.Find(what:=Milestone.Value, LookIn:=xlValues, lookat:=xlWhole).Column
                If Not DateCol = 0 Then NewSheet.Cells(Milestone.Row, Contract.Column).Value = Main.Cells(DateRow, DateCol)
                DateCol = 0
                On Error GoTo 0
            Next Milestone
        End If
        Set ContractRow = Nothing
        On Error GoTo 0
    Next Contract
    Application.ScreenUpdating = True
End Sub

Sub [COLOR=#ff0000]CreateTableB[/COLOR]()
Const Date1 = "[COLOR=#000080]C8[/COLOR]"                  '= ref of first cell with a date
Const Contract1 = "[COLOR=#000080]B10[/COLOR]"             '= ref of first cell with contract name (or reference)
Const MySheet = "Data"       '= name of sheet containing data

Dim Main As Worksheet, NewSheet As Worksheet, Milestones As Variant, Milestone As Variant
Dim DateRng As Range, ContractRng As Range, TextRng As Range, Contract As Range, MilestoneRng As Range, NewContractRng As Range
Dim ContractRow As Range, DateRow As Long, DateCol As Long
Set Main = Sheets(MySheet)
'set first cells and get validation list
    Set DateRng = Main.Range(Date1)
    DateRow = DateRng.Row
    Set ContractRng = Main.Range(Contract1)
    Set TextRng = Main.Cells(ContractRng.Row, DateRng.Column)
    Milestones = Split(TextRng.Validation.Formula1, ",")
'expanded to set complete range
    Set ContractRng = Range(ContractRng, Main.Cells(Rows.Count, ContractRng.Column).End(xlUp))
'add new sheet and create outline
    Application.ScreenUpdating = False
    Set NewSheet = Sheets.Add(after:=Main)
        With NewSheet
            Set MilestoneRng = .Range("B1").Resize(, UBound(Milestones) + 1)
                MilestoneRng.Value = Milestones
            Set NewContractRng = .Range("A2").Resize(ContractRng.Rows.Count)
                ContractRng.Copy: NewContractRng.PasteSpecial Paste:=xlPasteValues
            Call AddFormat(.UsedRange, DateRng)
        End With

'enter data in cells
    For Each Contract In NewContractRng
        On Error Resume Next
        Set ContractRow = Main.Rows(ContractRng.Find(what:=Contract.Value, LookIn:=xlValues, lookat:=xlWhole).Row)
        If Not ContractRow Is Nothing Then
            For Each Milestone In MilestoneRng
                On Error Resume Next
                DateCol = ContractRow.Find(what:=Milestone.Value, LookIn:=xlValues, lookat:=xlWhole).Column
                If Not DateCol = 0 Then NewSheet.Cells(Contract.Row, Milestone.Column).Value = Main.Cells(DateRow, DateCol)
                DateCol = 0
                On Error GoTo 0
            Next Milestone
        End If
        Set ContractRow = Nothing
        On Error GoTo 0
    Next Contract
    Application.ScreenUpdating = True
End Sub

 

[garyi]

Hi Yongle, I have tried the new code, with the same outcome I am afraid.

Could it be anything to do with the date format?

https://1drv.ms/u/s!Avv8aWrdMx__kdsAdzMTsKF7Sugpbw

Its kind of a mid year start from september 18 to august 19 if that makes any difference? Perhaps the VBA could just copy/paste the content of that date row? (Sorry trying to learn what you have done!)

 

[Yongle]

Which values are you using:

Const Date1 = "??"
Const Contract1 = "??"

 

[garyi]

Hi there date is F8 contract is B10

 

[Yongle]

Nothing obvious is jumping out at me
I am busy right now but later today I will send you amended code that returns various values along the way which will help you diagnose what the problem is

 

[Yongle]

You do have merged cells in your data (those can cause problems in VBA) - I am beginning to wonder if one of those is the culprit here
- if this test gets you nowhere start a new sheet without any merged cells with Contract names in B10 to B14, dates in F8 to T8, data in F10 to T14
- and run the macro against that sheet

Code amended to build a few strings which may help you work out what is not working - values are dumped to 3 message boxes and also printed to immediate window
(to see immediate window when in VBA - shortcut {CTRL} G )

I added the extra columns in my data so that the first date is in column F to match your layout and the code works without a hitch
- in my sheet contract names are in B10 to B14, dates are in F8 to T8, data in F10 to T14
- run the amended code and see if something looks peculiar (or out of whack with values below)
- the cell reference in message box 3 is where the matched date is found

These are the values returned based on the data inserted in my data range
Message box1
1st date in cell F8, value = 01/01/2019, row = 8
1st contract is in cell B10, 1st value is in cell F10
1st App, pre qual, site visit, tender sub, shortlist, presentation, decision, award, start date
Contract Range = B10:B14

Message box 2
Milestone range in new sheet = A2:A10
Contract range in new sheet = B1:F1

Message box 3
Example Contract1
1st App F8 pre qual G8 site visit H8 tender sub I8 shortlist J8 presentation K8 decision L8 award M8 start date N8
Example Contract2
1st App G8 pre qual H8 site visit I8 tender sub J8 shortlist K8 presentation L8 decision M8 award N8 start date R8
Example Contract3
1st App H8 pre qual I8 site visit J8 tender sub K8 shortlist L8 presentation M8 decision N8 award O8 start date P8
Example Contract4
1st App I8 pre qual J8 site visit K8 tender sub L8 shortlist M8 presentation N8 decision O8 award P8 start date S8
Example Contract5
1st App J8 pre qual K8 site visit L8 tender sub M8 shortlist N8 presentation O8 decision P8 award Q8 start date T8

Code below includes both message boxes and dump to immediate window

Sub CreateTableA()
Const Date1 = "F8"                  '= ref of first cell with a date
Const Contract1 = "B10"             '= ref of first cell with contract name (or reference)
Const MySheet = "Data"       '= name of sheet containing data

Dim Main As Worksheet, NewSheet As Worksheet, Milestones As Variant, Milestone As Variant
Dim DateRng As Range, ContractRng As Range, TextRng As Range, Contract As Range, MilestoneRng As Range, NewContractRng As Range
Dim ContractRow As Range, DateRow As Long, DateCol As Long
Dim myStr As String, mystr2 As String, ms As String, i As Long
Set Main = Sheets(MySheet)
'set first cells and get validation list
    Set DateRng = Main.Range(Date1)
    DateRow = DateRng.Row
    Set ContractRng = Main.Range(Contract1)
    Set TextRng = Main.Cells(ContractRng.Row, DateRng.Column)
    Milestones = Split(TextRng.Validation.Formula1, ",")

myStr = "1st date in cell " & DateRng.Address(0, 0) & ",  value = " & DateRng.Value
myStr = myStr & ",  row = " & DateRow
myStr = myStr & vbCr & "1st contract is in cell " & ContractRng.Address(0, 0)
myStr = myStr & ",   1st value is in cell " & TextRng.Address(0, 0)
ms = Milestones(0)
For i = 1 To UBound(Milestones)
    ms = ms & ", " & Milestones(i)
Next i
myStr = myStr & vbCr & ms

'expanded to set complete range
    Set ContractRng = Range(ContractRng, Main.Cells(Rows.Count, ContractRng.Column).End(xlUp))
myStr = myStr & vbCr & "Contract Range = " & ContractRng.Address(0, 0)
Main.Activate
MsgBox myStr
Debug.Print myStr & vbCr
myStr = ""
'add new sheet and create outline
    Application.ScreenUpdating = False
    Set NewSheet = Sheets.Add(after:=Main)
        With NewSheet
            Set MilestoneRng = .Range("A2").Resize(UBound(Milestones) + 1)
myStr = myStr & vbCr & "Milestone range in new sheet = " & MilestoneRng.Address(0, 0)
                MilestoneRng.Value = WorksheetFunction.Transpose(Milestones)
        
            Set NewContractRng = .Range("B1").Resize(, ContractRng.Rows.Count)
                ContractRng.Copy: NewContractRng.PasteSpecial Paste:=xlPasteValues, Transpose:=True
myStr = myStr & vbCr & "Contract range in new sheet = " & NewContractRng.Address(0, 0)
            Call AddFormat(.UsedRange, DateRng)
        End With
'enter data in cells
    For Each Contract In NewContractRng
        On Error Resume Next
mystr2 = mystr2 & vbCr & Contract.Value & vbCr
        Set ContractRow = Main.Rows(ContractRng.Find(what:=Contract.Value, LookIn:=xlValues, lookat:=xlWhole).Row)
        If Not ContractRow Is Nothing Then
            For Each Milestone In MilestoneRng
                On Error Resume Next
mystr2 = mystr2 & Milestone.Value
                DateCol = ContractRow.Find(what:=Milestone.Value, LookIn:=xlValues, lookat:=xlWhole).Column
mystr2 = mystr2 & " " & Cells(DateRow, DateCol).Address(0, 0) & " "
                If Not DateCol = 0 Then NewSheet.Cells(Milestone.Row, Contract.Column).Value = Main.Cells(DateRow, DateCol)
                DateCol = 0
                On Error GoTo 0
            Next Milestone
        End If
        Set ContractRow = Nothing
        On Error GoTo 0
    Next Contract
    Application.ScreenUpdating = True
NewSheet.Activate
MsgBox myStr
Debug.Print myStr & vbCr
Main.Activate
MsgBox mystr2
Debug.Print mystr2
End Sub

 

[garyi]

Hi thanks for this, wayyy over my head but its doing something!

It failed to work in my sheet so I started another sheet


https://1drv.ms/u/s!Avv8aWrdMx__kdsEIxw4XXMsWlM5UQ

This is what it throws up

https://1drv.ms/u/s!Avv8aWrdMx__kdsFeP1xQ6ux6NSfhQ

https://1drv.ms/u/s!Avv8aWrdMx__kdsH-D12EgXDxsHx_g

https://1drv.ms/u/s!Avv8aWrdMx__kdsGxub4UOiiWL4PTg

However in the new sheet still no data in the cells, I checked to see if the text was white or something but nothing is in the cells.

Could it be because I have conditional formatting in the original cells?

Should I create a list on a separate tab for the data validation?

Thank you for your assistance, I am sure its something silly I am doing, my only other thought is the date range formatting perhaps I have dones something odd there.

 

[garyi]

I notice in your final feedback box it lists the cell next to each milestone, in mine it does not, so perhaps something to do with the pop up cells on the original sheet?

 

[Yongle]

Ok - will get back to you tomorrow - fully committed this pm

 

[Yongle]

I suspect VBA is having a problem finding the dates
I have rewritten the code and hard-wired the first cells of each range
Amend sheet name and try again...

Sub CreateTable4()
Const MySheet = "[COLOR=#ff0000]Data[/COLOR]"

Dim Main As Worksheet, NewSheet As Worksheet
Dim Contracts As Range, DateRng As Range, Contract As Range, cel As Range
Dim c As Long, r As Long, MilestoneDate, Milestone As String
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))

Contracts.Copy: NewSheet.Range("B1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
DateRng.Copy: NewSheet.Range("A2").PasteSpecial Paste:=xlPasteAll, Transpose:=True

For Each Contract In Contracts
    For Each cel In Main.Cells(Contract.Row, "F").Resize(, DateRng.Columns.Count)
        If cel.Value <> "" Then
            On Error Resume Next
            c = NewSheet.Range("1:1").Find(Contract).Column
            Milestone = cel.Value
            MilestoneDate = DateValue(Main.Cells(8, cel.Column))
            r = NewSheet.Range("A:A").Find(what:=MilestoneDate, LookIn:=xlFormulas).Row
            NewSheet.Cells(r, c) = Milestone
        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