20170912xlVBA批量导入txt文件

Public Sub BatchImportTextFiles()
    AppSettings

    'On Error GoTo ErrHandler

    Dim StartTime, UsedTime As Variant
    StartTime = VBA.Timer
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    Dim wb As Workbook
    Dim Sht As Worksheet
    Dim OpenWb As Workbook
    Dim OpenSht As Worksheet
    Const SHEET_INDEX = 1
    Const HEAD_ROW As Long = 1
    Dim oSht As Worksheet

    Dim FolderPath As String
    Dim FileName As String
    Dim FileCount As Long

    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    Set wb = Application.ThisWorkbook
    Set Sht = wb.Worksheets("汇总")
    Sht.UsedRange.Offset(1).ClearContents

    Set oSht = wb.Worksheets("Temp")

    FolderPath = wb.Path & "\"
    FileCount = 0
    FileName = Dir(FolderPath & "*.txt*")
    Do While FileName <> ""
        filepath = FolderPath & FileName
        Debug.Print filepath
        oSht.Cells.ClearContents
        With oSht.QueryTables.Add(Connection:= _
            "TEXT;" & filepath, Destination:=oSht.Range("A1"))
        '.CommandType = 0
        .Name = Replace(FileName, ".txt", "")
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 936
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(2, 1, 1, 1, 1, 1)
        .TextFileFixedColumnWidths = Array(5, 11, 9, 8, 14)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With

    oSht.UsedRange.Offset(1).Copy Sht.Cells(Sht.Cells.Rows.Count, 1).End(xlUp).Offset(1)

    FileName = Dir
Loop
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
UsedTime = VBA.Timer - StartTime
Debug.Print "UsedTime ：" & Format(UsedTime, "#0.0000 Seconds")
'MsgBox "UsedTime ：" & Format(UsedTime, "#0.0000 Seconds")

ErrorExit:
Set wb = Nothing
Set Sht = Nothing
Set OpenWb = Nothing
Set OpenSht = Nothing
Set Rng = Nothing

AppSettings False
Exit Sub
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
ErrHandler:
If Err.Number <> 0 Then
    MsgBox Err.Description & "！", vbCritical, " QQ 84857038"
    'Debug.Print Err.Description
    Err.Clear
    Resume ErrorExit
End If
End Sub

Public Sub AppSettings(Optional IsStart As Boolean = True)
    Application.ScreenUpdating = IIf(IsStart, False, True)
    Application.DisplayAlerts = IIf(IsStart, False, True)
    Application.Calculation = IIf(IsStart, xlCalculationManual, xlCalculationAutomatic)
    Application.StatusBar = IIf(IsStart, ">>>>>>>>Macro Is Running>>>>>>>>", False)
End Sub