20161212xlVBA文本文件多列合并

Sub NextSeven_CodeFrame()
'应用程序设置
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual

    '错误处理
    'On Error GoTo ErrHandler

    '计时器
    Dim StartTime, UsedTime As Variant
    StartTime = VBA.Timer

    '变量声明
    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim Rng As Range
    Dim Arr As Variant
    Dim EndRow As Long
    Dim i&, j&

    '实例化对象
    Set Wb = Application.ThisWorkbook
    Set Sht = Wb.Worksheets(1)
    With Sht
        'EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
        'Set Rng = .Range("A2:Z" & EndRow)
        .UsedRange.Clear
    End With

    Dim FolderPath As String
    Dim FilenName As String
    Dim FileCount As Long
    Dim OpenWb As Workbook
    Dim oSht As Worksheet

    FolderPath = Wb.Path & ""
    '获取
    Arr = Array("A", "B", "C", "D", "E")
    For i = LBound(Arr) To UBound(Arr)
        Filename = Arr(i) & ".txt"
        Set OpenWb = OpenTextFile(FolderPath & Filename)
        Set oSht = OpenWb.Worksheets(1)
        With oSht
            EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
            Set Rng = .Range("A1:A" & EndRow)
            Rng.Copy Sht.Cells(1, i + 1)
        End With
        OpenWb.Close True
    Next i

   '合并
    Dim StrArr() As String
    With Sht
        EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
        Set Rng = .Range("A1:E" & EndRow)
        ReDim StrArr(1 To EndRow)
        Arr = Rng.Value
        For i = LBound(Arr) To UBound(Arr)
             StrArr(i) = Arr(i, 1) & "---" & Arr(i, 2) & "---" & Arr(i, 3) & _
                          "---" & Arr(i, 4) & "---" & Arr(i, 5)
                          Debug.Print StrArr(i)
        Next i
    End With
  
     '创建新txt
     Dim NewFile As Workbook
     Set NewFile = Application.Workbooks.Add
     Set oSht = NewFile.Worksheets(1)
     oSht.Range("A1").Resize(EndRow, 1).Value = Application.WorksheetFunction.Transpose(StrArr)
     NewFile.SaveAs FolderPath & "合并.txt", FileFormat:=xlUnicodeText, CreateBackup:=False
     NewFile.Close True
     '清理痕迹
     Sht.Cells.Clear
      
    '运行耗时
    UsedTime = VBA.Timer - StartTime
    MsgBox "本次运行耗时：" & Format(UsedTime, "0.0000000秒") 

ErrorExit:        '错误处理结束，开始环境清理
    Set Wb = Nothing
    Set Sht = Nothing
    Set Rng = Nothing

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    Exit Sub
ErrHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Description & "！", vbCritical, "错误提示！"
        'Debug.Print Err.Description
        Err.Clear
        Resume ErrorExit
    End If
End Sub
Private Function OpenTextFile(ByVal FilePath As String) As Workbook
' OpenTextFile 宏
    Dim Wb As Workbook
    Application.Workbooks.OpenText Filename:=FilePath, Origin _
                                                       :=936, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote _
                                 , ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:= _
                                                                                                    False, Space:=False, Other:=False, FieldInfo:=Array(1, 2), TrailingMinusNumbers:=True

    Set Wb = Application.ActiveWorkbook
    If Not Wb Is Nothing Then
        Set OpenTextFile = Wb
        Set Wb = Nothing
    Else
        Set Wb = Nothing
    End If
End Function