20161212xlVBA text file multi-column merge

Sub nextseven_codeframe () ' Application settings application.screenupdating = False Application.DisplayAlerts = False application . Calculation = Xlcalculationmanual ' Error handling ' On Error GoTo errhandler ' timer Dim StartTime, usedtime as Variant S Tarttime = VBA. Timer ' variable declaration Dim Wb As Workbook Dim Sht As Worksheet Dim Rng As Range Dim Arr As Variant Dim endrow As Lo ng Dim I& j& ' instanced object 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 & "\" ' Get ARR = Array ("A", "B", "C", "D", "E") F or 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 ' Hop and 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 (Ar                          R) 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 ' Create new txt Dim NewFile as Workbook set NewFile = Application.Workbooks.Add Set Osht = Newfile.workshee TS (1) osht.range ("A1"). Resize (Endrow, 1). Value = Application.WorksheetFunction.Transpose (strarr) newfile.saveas folderpath & "merge. txt", Fileformat:=xlunicodetext, Createbackup:=false newfile.close True ' cleanup traces Sht.Cells.Clear ' run time consuming use DTime = VBA. Timer-starttime MsgBox "This Run Time:" & Format (Usedtime, "0.0000000 Seconds") Errorexit: ' Error handling ended, start environment cleanup Set Wb = No    Thing Set Sht = Nothing Set Rng = Nothing application.screenupdating = True Application.DisplayAlerts = True Application.calculation = xlcalculationautomatic Exit suberrhandler:if err.number <> 0 Then MsgBox E Rr. Description & "! ", vbcritical," Error prompt! "' Debug.Print err.description err.clear Resume errorexit End ifend SubPrivate Function Opentextfi Le (ByVal FilePath as String) as Workbook ' OpenTextFile macro Dim Wb as Workbook Application.Workbooks.OpenText Filename: =filepath, Origin _: =936, Startrow:=1, datatype:=xldelimited, TEXTQ Ualifier:=xldoublequote _, Consecutivedelimiter:=false, TAb:=true, Semicolon:=false, comma:= _ False, Space:=false, Other:=false, Fieldinfo:=array (1, 2), trailingminusnumbers:=true Set Wb = Applicati Mnl ActiveWorkbook If not WB was nothing Then set OpenTextFile = WB Set wb = Nothing Else Set wb = N othing End IfEnd Function

　　

20161212xlVBA text file multi-column merge