Excel Macro to create Header and lines and save with Pipe CSV format

Hello Karedog,

there is a slight change to this file and I've tried making it in this file but was unsuccessful in changing the code. can you please help? I've attached a new version of the file and highlighted the row.

i get an error on 'z(strKey)(4).Add Array(a(i, 2), a(i, 3), a(i, 7))' I've moved the cols across but not sure why.

Sub Test()
  Const outputFilename As String = "Test.csv"
  Const c1  As String = "XXXX"
  Dim a, d, i As Long, strKey As String, strResult As String, v1, v2, z As New Collection
  With Sheets("Sheet1")
    d = .Range("B1:B3").Value
    a = .Range("A5").CurrentRegion.Value
  End With
  For i = 2 To UBound(a, 1)
      strKey = a(i, 1)
      On Error Resume Next
         z.Add key:=strKey, Item:=Array(a(i, 1), a(i, 4), a(i, 5), a(i, 6), New Collection)
      On Error GoTo 0
      z(strKey)(4).Add Array(a(i, 2), a(i, 3), a(i, 7))
  Next i
  For Each v1 In z
      strResult = strResult & "H|" & c1 & "|" & v1(1) & "|AA|00|XXXX|||" & v1(2) & "||" & v1(3) & "|" & d(2, 1) & "|" & d(3, 1) & vbCrLf
      For Each v2 In v1(4)
          strResult = strResult & "I|" & v2(0) & "|" & v2(1) & "|" & d(1, 1) & "||" & v2(2) & vbCrLf
      Next v2
  Next v1
  i = FreeFile
  Open ThisWorkbook.Path & "\" & outputFilename For Output As #i
    Print #i, strResult
  Close #i
End Sub

o