使用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