Create and Write to a text file using an excel macro and VBA

Question

I am using a macro and VBA code to create a text file with a specific format. All the data needed to create the text file is gathered from the macro cells. I have attached pictures of the macro data file and the output text file (please see below).

excel macro with data

Desired output txt format-example

Also, below is my VBA code I generated to get data from the macro and create/write into a text file. I still need to figure out how to write it in the specified format (Desired output txt format-example).

 Sub ExcelToTxt() 
'Declaring variables 
Dim lCounter As Long 
Dim lLastRow As Long 
Dim destgroup As String 
Dim parmlabel as Variant 
Dim FName As Variant 

'Activate Sheet1 
Sheet1.Activate 

'Find the last row that contains data 
With Sheet1 
    lLastRow = .Cells(.Rows.Count, "A").End(xlDown).Row 
End With

'Create txt file 
FName = Application.GetSaveAsFilename("", "txt file (*.txt), *.txt") 

'Open FName For Output As #1
For lCounter = 2 To lLastRow 
    'Read specific data from the worksheet 
    With Sheet1 destgroup = .Cells(lCounter, 19) 
        parmlabel = .Cells(lCounter, 8) 
        If destgroup="trex_15hz" Or destgroup="trex_10hz" Or destgroup="trex_5hz" Then 
            'Write selected data to text file 
            'Write #1, parmlabel 
        End If
    End With
'Continue looping until the last row 
Next lCounter 

'Close the text file 
Close #1 

End Sub

Any help with what I need to add in my VBA to create the formatted output txt file will be greatly appreciate it.

Thank you in advance.

Answer 1

You can combine the data into an array and then convert it back into text.

Sub ExcelToTxt()
'Declaring variables
    Dim i As Long, j As Integer
    Dim n As Long, k As Long
    Dim destgroup As String
    Dim FName As String
    Dim vDB, vR(1 To 6), vJoin(), vResult()
    Dim sJoin As String, sResult As String
    Dim s As Long
    'Activate Sheet1
    Sheet1.Activate

    'Find the last row that contains data
    With Sheet1
        vDB = .Range("a1").CurrentRegion '<~~ get data to array from your data range
        n = UBound(vDB, 1) 'size of array (row of 2 dimension array)
    End With

    'Create txt file
    FName = Application.GetSaveAsFilename("", "txt file (*.txt), *.txt")

    For i = 2 To n '<~~loop
            destgroup = vDB(i, 2) '<~~ second column
            If destgroup = "trex_15hz" Or destgroup = "trex_10hz" Or destgroup = "trex_5hz" Then

                vR(1) = "; ### LABEL DEFINITION ###" '<~~ text 1st line
                s = Val(Replace(vDB(i, 3), "label", ""))
                vR(2) = "EQ_LABEL_DEF,02," & Format(s, "000")
                vR(3) = "UDB_LABEL," & Chr(34) & vDB(i, 4) & Chr(34) '<~~ 2nd line

                    ReDim vJoin(4 To 7)
                    vJoin(4) = Chr(34) & vDB(i, 4) & Chr(34)
                    For j = 5 To 7
                        vJoin(j) = vDB(i, j)
                    Next j
                    sJoin = Join(vJoin, ",")

                vR(4) = "STD_SUB_LABE," & sJoin '<~~ 3th line

                    ReDim vJoin(8 To 12)
                    vJoin(8) = Chr(34) & UCase(vDB(i, 8)) & Chr(34)
                    vJoin(9) = Chr(34) & vDB(i, 9) & Chr(34)
                    vJoin(10) = Format(vDB(i, 10), "#.000000000")
                    For j = 11 To 12
                        vJoin(j) = vDB(i, j)
                    Next j
                    sJoin = Join(vJoin, ",")

                vR(5) = "STD_SUB_LABE," & sJoin '<~~ 4the line
                vR(6) = "END_EQ_LABEL_DEF"  '<~~ 5th line
                k = k + 1
                ReDim Preserve vResult(1 To k)
                vResult(k) = Join(vR, vbCrLf) '<~~ 5 line in array vR and get to array vResult with join method
            End If
    Next i
    sResult = "EQUIPMENT_ID_DEF,02,0x1," & Chr(34) & "trex" & Chr(34) '<~~ text file first line
    sResult = sResult & vbCrLf & Join(vResult, vbCrLf) '<~~ combine 1th and other line

    ConvertText FName, sResult '<~~ sub presedure
End Sub
Sub ConvertText(myfile As String, strTxt As String)
    Dim objStream

    Set objStream = CreateObject("ADODB.Stream")
    With objStream
        '.Charset = "utf-8"
        .Open
        .WriteText strTxt
        .SaveToFile myfile, 2
        .Close
    End With
    Set objStream = Nothing

End Sub