20161212xlVBA文本文件多列合並
阿新 • • 發佈:2017-07-07
多列 workbook msgbox time minus 清理 number iter 設置
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
20161212xlVBA文本文件多列合並