Snasui Excel Forum

Code: Select all

Sub Getdata()

'
    Dim strPath As Variant, i As Integer
    Dim tb As Workbook
    
    Sheets(1).Select
    On Error Resume Next
    Cells.Select
    Selection.ClearContents
    On Error GoTo 0
    
    Set tb = ThisWorkbook

        strPath = Application.GetOpenFilename("Excel files(*.xlsx*),*.xlsx*", _
        Title:="Please select text files.", MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
   
    For i = 1 To UBound(strPath)
        fName = VBA.Left(strPath(i), InStr(strPath(i), ".")) & "xlsx"
        Workbooks.OpenText Filename:=strPath(i), origin:=65001, startrow:=1, DataType:=xlDelimited, textQualifier:= _
        xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False _
        , Comma:=False, Space:=False, other:=True, OtherChar:="|", fieldinfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 2), Array(5, 1), Array(6, 1), _
        Array(7, 1), Array(8, 1)), TrailingMinusNumbers:=True
        
        With ActiveWorkbook.Sheets(1)
        
            .Range("a2").Offset(0, .UsedRange.Columns.Count) _
                .Resize(.UsedRange.Rows.Count - 1, 1).Value = .Name
            .UsedRange.Offset(0, 0).Copy
        End With

        With tb.Sheets(1)

            .Range("a" & .Rows.Count).End(xlUp).Offset(0, 0).PasteSpecial xlPasteValues

        End With
        Application.CutCopyMode = False
        ActiveWorkbook.Close False
    Next i
    
    MsgBox "Finish."
    
End Sub