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
