Private Sub Worksheet_Activate()
Dim LastRow, Marker, i, j As Integer
Dim DI As Worksheet
Dim Arr()
Set DI = Worksheets("Data_Input")
'Finds last row used
LastRow = DI.Range("A65536").End(xlUp).Row
Marker = 2
For i = 4 To LastRow
If DI.Cells(i, 1) <> "" Then
If Not "%" & Join(Arr, "%") & "%" Like "*%" & DI.Cells(i, 1).Value & "%*" Then
ReDim Preserve Arr(1 To UBound(Arr) + 1)
Arr(UBound(Arr)) = DI.Cells(i, 1).Value
Cells(Marker + 1, 1) = "ECM"
Cells(Marker + 1, 2) = DI.Cells(i, 1)
Cells(Marker + 2, 1) = DI.Cells(i, 2)
Cells(Marker + 2, 2) = DI.Cells(i, 3)
Cells(Marker + 2, 3) = DI.Cells(i, 26)
Cells(Marker + 2, 4) = DI.Cells(i, 27)
Cells(Marker + 2, 5) = DI.Cells(i, 28)
Marker = Marker + 2
For j = i + 1 To LastRow
If DI.Cells(j, 1).Value = DI.Cells(i, 1).Value Then
Cells(Marker + 1, 1) = DI.Cells(j, 2)
Cells(Marker + 1, 2) = DI.Cells(j, 3)
Cells(Marker + 1, 3) = DI.Cells(j, 26)
Cells(Marker + 1, 4) = DI.Cells(j, 27)
Cells(Marker + 1, 5) = DI.Cells(j, 28)
Marker = Marker + 1
End If
Next j
Marker = Marker + 2
End If
End If
Next i
End Sub