List cells based on text macro

garyi

New Member
Joined
Oct 3, 2013
Messages
22
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.
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Please detail EXACTLY what you want on the other sheet

1. Do you want all information for all contracts - something like below ( where column A is the cell text )

Contract1
Contract2Contract3
Start date
01/01/201926/01/201920/02/2019
MS 1 date21/01/201915/02/201912/03/2019
MS 2 date10/02/201907/03/201901/04/2019
MS 3 date02/03/201927/03/201921/04/2019
MS 4 date11/05/2019
End date01/04/201926/04/201921/05/2019

<tbody>
</tbody>

If the above layout is not what you want, please provide expected layout

2. Or do you want limited information (eg all start dates) based on a search
- please detail expected layout etc

3. Unless you tell me othersise, I will assume that your source data is structured as follows
- date row is row1 with first date in A2
- dates in row1 are numbers formatted as dates (NOT text)
- contract reference is in column A with first contract in A2
- first cells containing "specific text" is B2

4. If any cells do not contain your "specific text" are they empty?

5. Your 7 "date specific" things
- please paste the Data Validation Source formula into your reply (I'll tailor solution to use your formula)
 
Last edited:
Upvote 0
Hello there, sorry I replied but it did not stick so I shall try again!

Your layout looks perfect.

3. This will be infe, I have some limited VBA experience so cxould probably make some changes.

4. The cells are pop ups that are also conditionally formatted to change colour depending on whats picked. This is not important on the new tab though If there is nothing selected then the cell is empty but does have a condition of having an black outline, not sure if that matters

5. I did not have Source persay, I just did a data validation, then list and entered the items in the list.


Thank you very much for any help you can offer. I did used to be ok with VBA but when you don't use it for long periods it soon slips away from the aging mind!
 
Upvote 0
Code adds a sheet with table of values
This assumes that any text value only appears ONCE per contract

Paste code into a standard module
The second sub is called from the first and needs to be in the same module
Amend the 3 red values to match your data
And run it

Code:
Sub CreateTable()
Const Date1 = "[COLOR=#ff0000]B1[/COLOR]"                  '= ref of first cell with a date
Const Contract1 = "[COLOR=#ff0000]A2[/COLOR]"              '= ref of first cell with contract name (or reference)
Const MySheet = "[COLOR=#ff0000]Data[/COLOR]"              '= 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

Code:
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
 
Last edited:
Upvote 0
Put this in the same module and the table of values is created with contracts in rows instead

Code:
Sub CreateTable2()
Const Date1 = "B1"                  '= ref of first cell with a date
Const Contract1 = "A2"              '= 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
 
Upvote 0
Thanks yongle sorry for the delayed response I have been house renovating!

I will give this a go later and let you know how I got on.
 
Upvote 0
OK have entered the module data. It creates a new sheet lists the contracts along the top and list the milestones down the side, however its not entering any dates? Other than that its perfect for my needs!

Thank you.
 
Upvote 0
Ok - we need to work out what is different between your worksheet and mine
- it could be layout related or the type of values found in cells not matching


Below is my sheet - with CONTRACTS in A1
CONTRACTS 01-01
02-0103-0104-0105-0106-0107-0108-0109-01
contract001
StartM1M2M5End
contract002
StartM1M2
contract003
StartM3
contract004
StartM1M2
contract005
StartM4
contract006
StartM1M2

<tbody>
</tbody>

cell B1 value 01-01 is DATE (not text) Ist January 2019 formatted dd-mm etc
M1... M5 are 5 milestones

In which ways do your worksheet differ?
Which row is DATE row?
Which column in DATE row contains first date?
Which cell contains first contract?
etc

This is what the macro generates:
contract001contract002contract003contract004contract005contract006
Start01-0102-0103-0104-0105-0106-01
M103-0104-0107-0108-01
M205-0105-0108-0109-01
M305-01
M409-01
M507-01
End08-0113-0113-0113-0114-0114-01

<tbody>
</tbody>


Do you want milestones or contracts as column headers?
 
Last edited:
Upvote 0
Hi there here is my main page where I enter data

s!Avv8aWrdMx__kdptzQOAIcxeTayvjQ


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


The date format I believe is right across the top and I made sure all those cells are set to date format

You can see some of the cells are entered, these cells are the pop up list

that pop up list and contract listing works fine on the tab thats generated from your code. BUt as you can see no date, I set F8 as the first date cell

https://1drv.ms/u/s!Avv8aWrdMx__kdpsFTAuK3agnXMx-w


 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,531
Messages
6,114,172
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top