将excel文件导出为具有相同格式的txt

时间:2013-10-09 13:09:47

标签: excel excel-vba text formatting vba

我有一个以这种方式编写的excel文件:

187712  201    37     0.18   
2525    580    149    0.25   
136829  137    43     0.31

我需要在txt文件中使用相同的空格,相同的格式导出此文件。我该怎么做?我试过Save As | Formatted Text (Space Delimited) (*.prn)但没有工作因为我在最后一栏有问题。有宏吗?感谢。

编辑:我尝试了一个宏:

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

但结果是

187712  201    37     0.18   
2525 580  149    0.25   
136829  137    43     0.31

这些值只是一个例子,因为大约有504列!!无论如何,问题在于,如果第一列中的值比其他值短,则会丢失格式,如第二行所示。

2 个答案:

答案 0 :(得分:1)

我也经常多次努力,我找到的唯一方法是使用我创建的VBA功能(棘手的部分是确定"最宽的"用于纯文本布局的列)。公平警告:我没有建立很多" smarts"对此,输出可能有点古怪。

使用方法: 选择要格式化为纯文本的单元格,然后运行宏(我将宏分配给按钮,我一直使用它!)。如果顶行是中心对齐的,那么让我们/假设/它是一个标题。并观察右对齐列,并输出右对齐列。

marco会将所需的输出复制到剪贴板,然后将结果粘贴到记事本(或类似)中,以便根据需要进行操作。

示例输出(我扔了一些标题)

CustId  Views  Selected  Cost
187712    201        37  0.18
  2525    580       149  0.25
136829    137        43  0.31

代码:

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

答案 1 :(得分:1)

您发布的数据显示字段宽度为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

还假设数据从A列开始。