20161212xlVBA文本文件多列合并

?

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112

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