将excel 导出为txt，以空格分隔

roric2018

找了几个论坛里的代码但不是无法保存到当前文件，就是到处的数字格式带逗号，求教老师，需求如下：


1. 将当前活动sheet或者选中的sheet导出为txt
2. txt数字用空格分隔，不能是逗号或者符号
3. 生成的txt文件名为sheet名称
4. 保存路径：保存在excel所在路径下，但要先自动在当前文件夹下建一个名叫“Upload”的文件夹，并将生成的txt保存在里面.
5. 避免文档后的大量空格

附上excel文档，和应该生成的txt文件模板.

非常非常感谢！

hmlstfqtl

1. Sub 当前工作表另存为TXT()
   
2.     Dim Arr, k%, Str$
   
3.     Arr = [A1].CurrentRegion.Value
   
4.     For k = 1 To UBound(Arr)
   
5.         Str = Str & Join(Application.Index(Arr, k), " ") & vbCrLf
   
6.     Next
   
7.     On Error Resume Next
   
8.     MkDir ThisWorkbook.Path & "\Upload"
   
9.     Kill ThisWorkbook.Path & "\Upload" & ActiveSheet.Name & ".txt"
   
10.     Open ThisWorkbook.Path & "\Upload" & ActiveSheet.Name & ".txt" For Output As #1
    
11.     Print #1, Str
    
12.     Close #1
    
13. End Sub
    

复制代码

一把小刀闯天下

Option Explicit

Sub test()
  Dim defaultpath, arr, i, j, t, s
  arr = ActiveSheet.[a1].CurrentRegion
  defaultpath = ThisWorkbook.Path & "\upload"
  If Len(Dir(defaultpath, vbDirectory)) = 0 Then MkDir defaultpath
  Open defaultpath & "\" & ActiveSheet.Name & ".txt" For Output As #1
  For i = 1 To UBound(arr, 1)
    s = Trim(arr(i, 1))
    For j = 2 To UBound(arr, 2)
      t = Trim(arr(i, j))
      If InStr(t, """") Then t = Replace(t, """", vbNullString)
      If InStr(t, ",") Then t = Replace(t, ",", vbNullString)
      If InStr(t, ".") Then t = Split(t, ".")(0)
      s = s & vbTab & t
    Next
    Print #1, s
  Next
  Close #1
End Sub

Yaong_3

1. Sub ExcelToTxt_Yaong()
   
2.     Dim Rng As Range, i%, j%
   
3.     Open "C:\MyOut.txt" For Output As #1    '导出位置为 C:\MyOut.txt
   
4.     With ActiveSheet
   
5.     Set Rng = .UsedRange
   
6.         For i = 1 To .UsedRange.Rows.Count
   
7.         For j = 1 To .UsedRange.Columns.Count
   
8.             Print #1, Trim(Rng.Cells(i, j)) & vbTab;    '分隔符为 Tab
   
9.         Next
   
10.             Print #1,
    
11.         Next
    
12.     End With
    
13.     Close #1
    
14. End Sub

复制代码

Yaong_3

有一点不很明白：直接复制然后粘贴到记事本里不行吗？

roric2018

一把小刀闯天下 发表于 2018-5-17 15:41
Option Explicit

Sub test()

非常感谢！

能否帮忙修改一处，现在导出的txt自动省略了小数点后的数字， 比如5.6666666会变成5， 没有小数点，能否改成如excel所示的位数，或者自动保留10位小数

麻烦了！谢谢！

一把小刀闯天下

roric2018 发表于 2018-5-17 17:52
非常感谢！

能否帮忙修改一处，现在导出的txt自动省略了小数点后的数字， 比如5.6666666会变成5， 没 ...

'自己修改

Option Explicit

Sub test()
  Dim defaultpath, arr, i, j, k, t, s
  arr = ActiveSheet.UsedRange
  defaultpath = ThisWorkbook.Path & "\upload"
  If Len(Dir(defaultpath, vbDirectory)) = 0 Then MkDir defaultpath
  Open defaultpath & "\" & ActiveSheet.Name & ".txt" For Output As #1
  For i = 1 To UBound(arr, 1)
    s = Trim(arr(i, 1))
    For j = 2 To UBound(arr, 2)
      t = Trim(arr(i, j))
      If InStr(t, """") Then t = Replace(t, """", vbNullString)
      If InStr(t, ",") Then t = Replace(t, ",", vbNullString)
      If IsNumeric(t) Then
        t = Val(t)
        If Int(t) <> t Then t = Format(t, "0.00") '非整数保留小数点位数
      End If
      s = s & vbTab & t
    Next
    Print #1, s
  Next
  Close #1
End Sub

道明星沐

路过，厉害！学习了

longer10010

hmlstfqtl 发表于 2018-5-17 14:46

感谢，适合自己