Board logo

標題: [發問] EXCEL VBA XLSX TO TXT 空白行 [打印本頁]
作者: dou10801    時間: 2020-11-25 14:13     標題: EXCEL VBA XLSX TO TXT 空白行

請教各位前輩,xlsx檔轉txt 對方要求最後面要加[21]個半型空白(如附件a001.txt),謝謝.[attach]32710[/attach]
作者: Joforn    時間: 2020-11-26 22:34

  1. Sub Test001()
  2.   Dim FileName  As String
  3.   Dim hFile     As Long
  4.   Dim lngEndRow As Long
  5.   Dim R As Long, C As Long
  6.   Dim bytText() As Byte
  7.   Dim strText   As String
  8.   Dim strCrLf   As String
  9.   
  10.   R = InStrRev(ThisWorkbook.Name, ".")
  11.   If R > 0 Then
  12.     FileName = Left$(ThisWorkbook.Name, R - 1)
  13.   Else
  14.     FileName = ThisWorkbook.Name
  15.   End If
  16.   strCrLf = Space(21) & vbCrLf
  17.   With Sheet1
  18.     lngEndRow = .Range("A" & .Rows.Count).End(xlUp).Row
  19.     hFile = FreeFile
  20.     Open ThisWorkbook.Path & Application.PathSeparator & FileName & ".TXT" For Binary As hFile
  21.     For R = 1 To lngEndRow
  22.       strText = vbNullString
  23.       For C = 1 To .UsedRange.Columns.Count
  24.         strText = strText & .Cells(R, C).Text
  25.       Next C
  26.       strText = strText & IIf(Len(strText), strCrLf, vbCrLf)
  27.       bytText() = StrConv(strText, vbFromUnicode)
  28.       Put hFile, , bytText()
  29.     Next R
  30.     Close hFile
  31.   End With
  32. End Sub
複製代碼
作者: dou10801    時間: 2020-11-27 08:41     標題: RE: EXCEL VBA XLSX TO TXT 空白行

感謝...約福恩大大指點,執行後出現,此處需要物件.
作者: quickfixer    時間: 2020-11-27 09:41

Sub test002()
    Open ThisWorkbook.Path & "\" & Split(ThisWorkbook.Name, ".")(0) & ".txt" For Output As #1
    For i = 1 To Range("a1").CurrentRegion.Rows.Count
        Print #1, Cells(i, 1) & Cells(i, 2) & Cells(i, 3) & Cells(i, 4) & Cells(i, 5) & Cells(i, 6) & Cells(i, 7) & Cells(i, 8) & String(21, " ")
    Next i
    Close #1
End Sub
作者: Joforn    時間: 2020-11-27 10:14

回復 3# dou10801
將With Sheet1改成With ActiveSheet試試
作者: dou10801    時間: 2020-11-27 11:09

回復 5# Joforn 可以了,感恩.
作者: dou10801    時間: 2020-11-27 11:10

感謝兩位前輩指導,收下範本學習.
作者: n7822123    時間: 2020-11-28 18:10

本帖最後由 n7822123 於 2020-11-28 18:20 編輯

回復 7# dou10801

上面兩位大大提供的程式 都需要寫在你的 "A001.xlsx" 檔案中，

考量到你可能有多個檔案 Ex A002,A003 可能都需要轉成txt，

每個檔案都要複製那段程式，會有點煩瑣

我提供一段程式，讓你自己設定來源路徑&檔名(xlsx) & 輸出路徑&檔名(txt)，會比較彈性

若要一次執行多個檔案，你可以自己改成迴圈

上面兩位大大都用 Open語法 做出純文字文件，我就換個寫法吧!

用Excel打開檔案(唯獨)，再另存成txt檔

這段程式不限制你要放在哪個Excel檔，輸入輸出(I/O)設定好即可

程式如下


Sub Test1128()
Dim Arr, R&, C&
myPath$ = ThisWorkbook.Path & "\"
xlsPath$ = myPath & "A001.xlsx"   'xls檔案來源路徑，請自行設定(預設本程式檔案路徑下)
txtPath$ = myPath & "A001.txt"     '輸出txt的路徑&檔名，請自行設定(預設本程式檔案路徑下)
With Workbooks.Open(xlsPath, , True).Sheets(1)
  Arr = .[A1].CurrentRegion
  For R = 1 To UBound(Arr)
    For C = 2 To UBound(Arr, 2)
      Arr(R, 1) = Arr(R, 1) & Arr(R, C)
    Next C
    Arr(R, 1) = Arr(R, 1) & String(20, " ")
  Next R
  .[A1].Resize(UBound(Arr), UBound(Arr, 2)) = Arr
  .Columns("B").Resize(, UBound(Arr, 2)).Delete
  .SaveAs txtPath, 42
  .Parent.Close True
End With
End Sub
作者: n7822123    時間: 2020-11-28 19:03

回復 8# n7822123

恩....21個空白字元，寫成20個了，這裡改一下

Arr(R, 1) = Arr(R, 1) & String(21, " ")
作者: dou10801    時間: 2020-11-30 08:29

感謝 n7822123 提供另一種思路,重複存檔時,系統會詢問,[是否要取代],如按[否]會中斷,如何解決,感恩.
作者: n7822123    時間: 2020-11-30 13:12

回復 10# dou10801

感謝 n7822123 提供另一種思路,重複存檔時,系統會詢問,[是否要取代],如按[否]會中斷,如何解決,感恩.

那就強制覆蓋，不詢問就好了，添加一行程式即可

Sub Test1130()
Dim Arr, R&, C&
Application.DisplayAlerts = False   '若已有檔案、直接覆蓋不詢問
myPath$ = ThisWorkbook.Path & "\"
xlsPath$ = myPath & "A001.xlsx"   'xls檔案來源路徑，請自行設定(預設本程式檔案路徑下)
txtPath$ = myPath & "A001.txt"     '輸出txt的路徑&檔名，請自行設定(預設本程式檔案路徑下)
With Workbooks.Open(xlsPath, , True).Sheets(1)
  Arr = .[A1].CurrentRegion
  For R = 1 To UBound(Arr)
    For C = 2 To UBound(Arr, 2)
      Arr(R, 1) = Arr(R, 1) & Arr(R, C)
    Next C
    Arr(R, 1) = Arr(R, 1) & String(21, " ")
  Next R
  .[A1].Resize(UBound(Arr), UBound(Arr, 2)) = Arr
  .Columns("B").Resize(, UBound(Arr, 2)).Delete
  .SaveAs txtPath, 42
  .Parent.Close True
End With
End Sub
作者: dou10801    時間: 2020-12-3 09:40

再次請教前輩,附件中選a0063.xlsx,轉成.txt時,為何會多第一行[編號],謝謝.
作者: n7822123    時間: 2020-12-5 02:58

本帖最後由 n7822123 於 2020-12-5 03:00 編輯

回復 12# dou10801


因為你的xlsx檔，本身就有標題列阿=.=

Arr 陣列一開始就會取到標題列，所以你的For迴圈，R改成從2開始也沒有用

最後把陣列的值貼回去儲存格還是有標題列~~

只要加1行程式刪掉第一列就好了


      MES = UBound(Arr) - 1
      .[A1].Resize(UBound(Arr), UBound(Arr, 2)) = Arr
      .Columns("B").Resize(, UBound(Arr, 2)).Delete
      .Rows(1).Delete
      .SaveAs txtPath, 42
      .Parent.Close True
    End With
作者: quickfixer    時間: 2020-12-5 09:11

回復 13# n7822123

後來給的檔案和一開始的範本,根本不一樣:@
多了標題列,金額那欄字數不固定,那個要加21個空白的條件,是錯的吧?
空白字數是其實變動的才對?還是金額那欄要補字數?
作者: n7822123    時間: 2020-12-5 14:11

本帖最後由 n7822123 於 2020-12-5 14:15 編輯

回復 14# quickfixer


後來給的檔案和一開始的範本,根本不一樣

沒錯!!!

多了標題列,金額那欄字數不固定,那個要加21個空白的條件,是錯的吧?
空白字數是其實變動的才對?還是金額那欄要補字數?   

這個我沒仔細看他後面的範本和他補的程式，看他需要什麼再去確認就好

我們可以靜觀其變
作者: dou10801    時間: 2020-12-7 08:13

回復 13# n7822123 感謝n7822123前輩指點,加 .Rows(1).Delete,已可以運作.感恩.
作者: dou10801    時間: 2020-12-7 08:28

回復 14# quickfixer quickfixer前輩,抱歉第二個範本是第一個範本的延伸功能,第二個範本是將最後不足空間補到81行.Arr = .[A1].CurrentRegion
      For R = 1 To UBound(Arr)
          p1 = Len(Cells(R, MDS4))  '備註欄長度.
          p2 = 29 - p1              '補空白長度
          mcs = mcs1 & Cells(R, MDS2) & Format(Cells(R, MDS3), "00000000000") & "00" & mcs2 & Cells(R, MDS4) & String(p2, " ")
          Arr(R, 1) = mcs
      Next R              金額是MSD3補0到11位,我沒說明清楚.



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)