CODE

Sub COSD_Lung_Add_MRN_etc()
'This works for Lung, Haem, Skin, UGI & Urology
'- as these have [CancerTreatmentStartDate] in the 'Treatment' worksheet - Table19.

Dim LastRow As Long
Dim LastCol As Long
Dim WS As Worksheet
Dim Sheet As Variant
Dim Sheets_Count As Long
Dim SheetsArray() As Variant

SheetsArray = Array("Linkage Patient ID", "Linkage Diagnosis", "Demographics", "ReferralAndPatientPathway", "Diagnostic Details", "CancerCarePlan", "Staging", "Person Observations")

ActiveWorkbook.Worksheets("Linkage Patient ID").Range("C1").FormulaR1C1 = "MRN"

For Each WS In ActiveWorkbook.Worksheets

With WS
.Activate

If WS.Name <> "Imaging" And WS.Name <> "Holistic Needs Assessment" And _
WS.Name <> "CancerRecurrenceSecondary" And _
WS.Name <> "DeathDetails" And WS.Name <> "Content" And _
WS.Name <> "Linkage Patient ID" Then

    LastRow = .Range("A1").CurrentRegion.Rows.Count
    LastCol = .Range("A1").CurrentRegion.Columns.Count
    
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
    End With
    ActiveWindow.FreezePanes = True
    
.Range("A1", .Cells(LastRow, LastCol)).Sort Key1:=Range("B1"), Header:=xlYes

'
    With .Columns("C:C")
    .Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    End With
    
    With .Range("C1")
    .ClearContents
    .FormulaR1C1 = "MRN"
    End With

    With .Range("C2")
    .ClearContents
    .FormulaR1C1 = "=VLOOKUP([@NHSNumber],'Linkage Patient ID'!C[-1]:C,2,0)"
    End With
    
    Range("C2").Select
        If LastRow > 2 Then ' Sometimes there's on one row of data
    Range(Selection, Selection.End(xlDown)).Select
        End If
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

Else:
End If 'If WS.Name <> etc

End With 'With WS

Next WS 'For Each WS In ActiveWorkbook.Worksheets

    Sheets("Treatment").Activate ' This is where I get the 'dates' column turned in to dates.
    Columns("E:E").Select
    Selection.TextToColumns Destination:=Range( _
        "Table19[[#Headers],[CancerTreatmentStartDate]]"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(0, 4), TrailingMinusNumbers:=True
        
''****************************************************************************************************
        'Pause here and then filter 'Treatment' worksheet to required Treatment Date before proceeding

For Each Sheet In SheetsArray
    
    With ActiveWorkbook.Worksheets(Sheet)
         
   .Activate
   
     LastRow = .Range("A1").CurrentRegion.Rows.Count
     
        With .Columns("D:D")
        .Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        End With
        
        With .Range("D1")
        .ClearContents
        .FormulaR1C1 = "Treatment Lookup"
        End With
    
        With .Range("D2")
        .ClearContents
       'Look up MRN based on filtered 'Treatment' worksheet
        .FormulaArray = "=VLOOKUP([@MRN],IF(SUBTOTAL(3,OFFSET(Table19[MRN],ROW(Table19[MRN])-ROW(C2),0,1)), Table19[MRN]),1,FALSE)" 'Look up MRN based on filtered 'Treatment' worksheet

        End With
        
        Range("D2").Select
                If LastRow > 2 Then
        Range(Selection, Selection.End(xlDown)).Select
                End If
        Selection.Copy
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
''
    End With 'With ActiveWorkbook.Worksheets(Sheet)
Next Sheet 'For Each Sheet In SheetsArray
 
End Sub