vba 以相同格式将excel文件导出到txt
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/19273014/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Export an excel file to txt with same formatting
提问by David_D
I have an excel file written in this way:
我有一个这样写的excel文件：
187712 201 37 0.18
2525 580 149 0.25
136829 137 43 0.31
I need to export this file with same spaces, same formatting in a txt file. How can i do it? I've tryied Save As | Formatted Text (Space Delimited) (*.prn)but not working because i have an issue on the last column. Is there a macro? Thanks.
我需要在txt文件中使用相同的空格和相同的格式导出此文件。我该怎么做？我已经尝试过Save As | Formatted Text (Space Delimited) (*.prn)但没有工作，因为我在最后一栏有问题。有宏吗 谢谢。
EDIT: i tryied a macro:
编辑：我尝试了一个宏：
Sub TEST()
Dim c As Range, r As Range
Dim output As String
For Each r In Range("A1:L504").Rows
For Each c In r.Cells
output = output & " " & c.Value
Next c
output = output & vbNewLine
Next r
Open "D:\MyPath\text.txt" For Output As #1
Print #1, output
Close
End Sub
but the result is
但结果是
187712 201 37 0.18
2525 580 149 0.25
136829 137 43 0.31
These values are only an example because there are about 504 columns!! Anyway the problem is that if in the first column there is a value shorter then the others it lost the formatting like the second row as you can see.
这些值只是一个例子，因为大约有 504 列！！无论如何，问题是，如果在第一列中有一个较短的值，那么其他列就会丢失格式，如您所见，第二行。
回答by JayRO-GreyBeard
I struggled with that also numerous times, the only way I found was with a VBA function I created (the tricky part is determining the "widest" column for plain-text layout). Fair warning: I didn't build a lot "smarts" into this, the output can be a little quirky.
我也为此挣扎了很多次，我发现的唯一方法是使用我创建的 VBA 函数（棘手的部分是确定纯文本布局的“最宽”列）。公平警告：我没有在其中构建很多“智能”，输出可能有点古怪。
Usage: Select the cells you want formatted to plain-text, then run the macro (I have the macro assigned to a button, I use it all the time!). If the top row is center-aligned, then let's /assume/ it's a header. And watch for right-aligned columns, and output those right-aligned.
用法：选择要格式化为纯文本格式的单元格，然后运行宏（我将宏分配给了一个按钮，我一直在使用它！）。如果顶行居中对齐，那么让我们/假设/它是一个标题。并注意右对齐的列，并输出那些右对齐的列。
The marco will copy the desired output to the clip-board, then paste the result in Notepad (or similar) to do with as desired.
marco 会将所需的输出复制到剪贴板，然后将结果粘贴到记事本（或类似工具）中以根据需要进行处理。
Example output (I threw in some headers)
示例输出（我加入了一些标题）
CustId Views Selected Cost
187712 201 37 0.18
2525 580 149 0.25
136829 137 43 0.31
The code:
编码：
Sub FormatSelectionToPlainText()
' ---------------------------------------------------------------------------
' Author: Jay R. Ohman
' Ohman Automation Corp., http://www.OhmanCorp.com
' ** disclaimer and release: I am NOT an expert **
' ** programmer, use my coding at your own risk! **
' ---------------------------------------------------------------------------
Dim rFound As Range, RngCol1 As Integer, RngRow1 As Integer, ActCol As Integer, ActRow As Integer, x As Integer
Dim MaxCellLen() As Variant, CellAlignRight() As Variant, HdrLen() As Variant, xDbg As Boolean, xVal As Variant
Dim SepSpace As Integer, RetStr As String, RetLen As Integer, MsgStr As String, HasHdr As Boolean
Dim GeneralIsRightAlignedFactor As Single, TotalRows As Integer
Dim oClip As DataObject
xDbg = True ' output stuff to the immediate window?
GeneralIsRightAlignedFactor = 0.75 ' threshhold for deeming a column as right-aligned
Set oClip = New DataObject
MsgStr = "(looking for top row to be center aligned as header)"
If MsgBox("Are the cells to be copied selected?" & vbCrLf & MsgStr, vbYesNo + vbQuestion, "Auto-Fill Time Slots") = vbYes Then
If (Selection Is Nothing) Then
MsgBox "Nothing Selected."
Else
SepSpace = 2 ' number of spaces between columns
RetLen = 0
HasHdr = True
Set rFound = Selection
RngCol1 = rFound.Column
RngRow1 = rFound.Row
Debug.Print Selection.Columns.Count
ReDim Preserve MaxCellLen(Selection.Columns.Count) ' max cell length
ReDim Preserve CellAlignRight(Selection.Columns.Count) ' track the cell alignment
ReDim Preserve HdrLen(Selection.Columns.Count) ' header row max cell length
For ActCol = RngCol1 To RngCol1 + Selection.Columns.Count - 1
x = (ActCol - RngCol1 + 1)
' If xDbg Then Debug.Print Cells(RngRow1, ActCol).HorizontalAlignment
If (Cells(RngRow1, ActCol).HorizontalAlignment <> xlCenter) And (Cells(RngRow1, ActCol).Value <> "") Then HasHdr = False
HdrLen(x) = IIf(HasHdr, Len(Cells(RngRow1, ActCol).Value), 0)
MaxCellLen(x) = 0
CellAlignRight(x) = 0
Next
If xDbg Then Debug.Print "HasHdr: " & HasHdr
TotalRows = (RngRow1 + Selection.Rows.Count) - (RngRow1 + IIf(HasHdr, 1, 0))
For ActCol = RngCol1 To RngCol1 + Selection.Columns.Count - 1 ' go find the longest text in each column
x = (ActCol - RngCol1 + 1)
xVal = IIf(HasHdr, 1, 0)
For ActRow = RngRow1 + xVal To RngRow1 + Selection.Rows.Count - 1
' If xDbg Then Debug.Print Cells(ActRow, ActCol).HorizontalAlignment
xVal = Cells(ActRow, ActCol).Value
If (MaxCellLen(x) < Len(Cells(ActRow, ActCol).Value)) Then MaxCellLen(x) = Len(xVal)
If (Cells(ActRow, ActCol).HorizontalAlignment = xlRight) Or _
((Cells(ActRow, ActCol).HorizontalAlignment = xlGeneral) And (IsDate(xVal) Or IsNumeric(xVal))) Then _
CellAlignRight(x) = CellAlignRight(x) + 1
Next
If xDbg Then Debug.Print "Max Length for Column " & ActCol & ": " & MaxCellLen(x) & _
", CellAlignRight.Count: " & CellAlignRight(x) & "/" & TotalRows
RetLen = RetLen + MaxCellLen(x) + SepSpace
Next
RetLen = RetLen - SepSpace ' subtract that last separator space
If HasHdr Then
For ActCol = RngCol1 To RngCol1 + Selection.Columns.Count - 1
x = (ActCol - RngCol1 + 1)
If (HdrLen(x) > MaxCellLen(x)) Then MaxCellLen(x) = HdrLen(x)
Next
End If
RetStr = "" ' build the output text
For ActRow = RngRow1 To RngRow1 + Selection.Rows.Count - 1
For ActCol = RngCol1 To RngCol1 + Selection.Columns.Count - 1
x = (ActCol - RngCol1 + 1)
MsgStr = Cells(ActRow, ActCol).Value ' re-use string variable
' format for right-aligned
If (CellAlignRight(x) / TotalRows >= GeneralIsRightAlignedFactor) And (Not (HasHdr And (ActRow = 1))) Or (Cells(ActRow, ActCol).HorizontalAlignment = xlRight) Then ' aligned right
RetStr = RetStr & Space(MaxCellLen(x) - Len(MsgStr)) & MsgStr
ElseIf (Cells(ActRow, ActCol).HorizontalAlignment = xlCenter) Then
xVal = Fix((MaxCellLen(x) - Len(MsgStr)) / 2)
RetStr = RetStr & Space(xVal) & MsgStr & Space(MaxCellLen(x) - Len(MsgStr) - xVal)
Else
RetStr = RetStr & MsgStr & Space(MaxCellLen(x) - Len(MsgStr))
End If
If ((ActCol - RngCol1) + 1 < UBound(MaxCellLen)) Then RetStr = RetStr & Space(SepSpace)
Next
RetStr = RetStr & vbCrLf
Next
oClip.SetText RetStr
oClip.PutInClipboard
MsgBox ("The selection has been copied to clipboard." & vbCrLf & "Max line length: " & RetLen)
End If
Else
MsgBox ("Have a nice day. :)")
End If
End Sub
回答by Gary's Student
Your posted data shows fixed fields with field-widths of 8,7,7,4 (each field is a combination of characters and trailing blanks). These can be adjusted as necessary in the macro below. Also adjust the folder name to suit your needs:
您发布的数据显示了字段宽度为 8、7、7、4 的固定字段（每个字段都是字符和尾随空格的组合）。这些可以根据需要在下面的宏中进行调整。还要调整文件夹名称以满足您的需要：
Sub FixedField()
Dim fld(1 To 4) As Long
Dim V(1 To 4) As String
Dim N As Long, L As Long
Dim K As Long
fld(1) = 8
fld(2) = 7
fld(3) = 7
fld(4) = 4
N = Cells(Rows.Count, "A").End(xlUp).Row
Close #1
Open "c:\TestFolder\test.txt" For Output As #1
For L = 1 To N
outpt = ""
For K = 1 To 4
V(K) = Cells(L, K).Text
While Len(V(K)) <> fld(K)
V(K) = V(K) & " "
Wend
outpt = outpt & V(K)
Next K
MsgBox outpt
Print #1, outpt
Next L
Close #1
End Sub
It is also assumed that the data starts in column A.
还假设数据从 A 列开始。
