Dynamic concatenation by header names, lost on how to do this - excel

Question

I need to a dynamic way to concatinate some cells in a row with a delimiter (in this instance |) as the columns move about (per project) this has to be by header names (there might be from 2 to many) columns that need to be concatinated for a project
I am trying to use arrays as there can be as many as 4000,000 rows
I have been trying for hours and here is my effort I know it is very wrong but I am at a loss
Thank you
Sub CAT()
fCAT "ElementsFile", "ElementsFile", "D", Array("Age", "Gender Identity", "Ethnicity1", "Ethnicity1")
End Sub
Sub fCAT(sShtName As String, pbShtName As String, InsertCol As String, ar As Variant)
Dim myresult
Dim col1 As String, col2 As String, col3 As String, col4 As String
Dim aLR As Long, i As Long, j As Long, k As Long
'Totaly at a loss here
For i = LBound(ar) To UBound(ar)
Dim ari As Variant
Dim coli As String
Next i
Set wsS = ThisWorkbook.Sheets(sShtName)
Set wsPB = ThisWorkbook.Sheets(pbShtName)
With wsS
aLR = .Range("A" & .Rows.Count).End(xlUp).Row
For i = LBound(ar) To UBound(ar)
j = .Rows(1).Find(ar(i)).Column
ari = .Range(Cells(1, j), Cells(aLR, j)).Select
Next i
End With
'Totaly at a loss here
ReDim myresult(1 To aLR, 1 To aLR)
For k = 1 To aLR
For i = LBound(ar) To UBound(ar)
j = wsS.Rows(1).Find(ar(i)).Column
myresult(k, 1) = Cells(k, j) & "|" & Cells(k, j + 1) & "|" & Cells(k, j + 2) & "|" & Cells(k, j + 3)
Next i
Next k
wsT.Range("D1").Resize(aLR, 1) = myresult
End Sub

Answer 1

Here is what I finally came up with a bit of a mess maybe but it works
Sub concat()
Dim myresult, CN
Dim HN As Variant
Dim wsS As Worksheet, wsPB As Worksheet
Dim str As String
Dim LR As Long, i As Long, j As Long, k As Long
HN = Array("Age", "Gender Identity", "Ethnicity1", "Ethnicity2")
Set wsS = ThisWorkbook.Sheets("ElementsFile")
Set wsPB = ThisWorkbook.Sheets("ElementsFile")
wsPB.Columns(4).Insert
ReDim CN(0 To UBound(HN))
With wsS
LR = .Range("A" & .Rows.Count).End(xlUp).Row
'Get Array of column numbers coresponding to Header names
For i = 0 To UBound(HN)
j = wsS.Rows(1).Find(HN(i)).Column
CN(i) = j
Next i
End With
ReDim myresult(1 To LR, 1 To 1)
For i = 1 To LR
str = vbNullString
If Not (IsEmpty(Cells(i, CN(0))) And IsEmpty(Cells(i, CN(1)))) Then
For k = UBound(HN) To 0 Step -1
If k <> UBound(HN) Then
str = Cells(i, CN(k)) & "|" & str
Else: str = Cells(i, CN(k)) & str
End If
Next k
myresult(i, 1) = str
Else
myresult(i, 1) = vbNullString
End If
Next i
str = vbNullString
wsPB.Range("D1").Resize(LR, 1) = myresult
End Sub