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
Code:
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