使用Excel宏和VBA创建和写入文本文件

Question

我正在使用宏和VBA代码创建具有特定格式的文本文件。所有创建文本文件所需的数据都是从宏单元中收集的。 我附上了宏数据文件和输出文本文件的图片（请参见下文）。

excel macro with data

Desired output txt format-example

此外，下面是我产生摆脱宏观数据和创建/写入到一个文本文件，我的VBA代码。我仍然需要弄清楚如何以指定的格式编写它（期望的输出txt格式示例）。

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 

任何帮助，我需要添加在我的VBA创建格式化输出txt文件将不胜感激。

预先感谢您。

Answer 1

您可以将数据组合成数组，然后将其转换回文本。

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