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

[spr2017]

Hello,

i'm hoping someone can help with this code. i have a standard excel format file that has to be saved as *.csv with '|" pipe delimiter. also each record must have a header and line items. "H" for header and "I" .

please see sample attached. Please help.

thanks heaps.

[karedog]

Maybe :

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

[spr2017]

this is great. however i can we do some formatting on d(1,1) as yyyymmdd? i can put this in this in the excel but will need a separate cell to convert. I really appreciate your help. its perfect.

[karedog]

Thanks for rep.points. Just add the code line in red below :

    d = .Range("B1:B3").Value
    d(1, 1) = Format$(d(1, 1), "YYYYMMDD")
    a = .Range("A5").CurrentRegion.Value

[spr2017]

Perfect thanks heaps

[spr2017]

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

[karedog]

It should be :

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, 2), a(i, 5), a(i, 6), a(i, 7), New Collection)
      On Error GoTo 0
      z(strKey)(5).Add Array(a(i, 3), a(i, 4), a(i, 8))
  Next i
  For Each v1 In z
      strResult = strResult & "H|" & c1 & "|" & v1(2) & "|" & v1(1) & "||00|" & c1 & "|||" & v1(3) & "||" & v1(4) & "|" & d(2, 1) & "|" & d(3, 1) & vbCrLf
      For Each v2 In v1(5)
          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

[spr2017]

thanks heaps.