Snasui Excel Forum

Code: Select all

Sub CombineTextFiles()
    Dim FilesToOpen
    Dim x As Integer
    Dim wkbAll As Workbook
    Dim wkbTemp As Workbook
    Dim sDelimiter As String

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    sDelimiter = "|"

    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="Text Files (*.txt), *.txt", _
      MultiSelect:=True, Title:="Text Files to Open")

    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "No Files were selected"
        GoTo ExitHandler
    End If
    x = 1
'    Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
    Workbooks.OpenText Filename:=FilesToOpen(x), Origin:= _
        65001, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False _
        , Space:=False, Other:=True, OtherChar:="|", FieldInfo:=Array(1, 1), _
        TrailingMinusNumbers:=True

'    wkbTemp.Sheets(1).Copy
'    Set wkbAll = ActiveWorkbook
'    wkbTemp.Close (False)
'    wkbAll.Worksheets(x).Columns("A:A").TextToColumns _
'      Destination:=Range("A1"), DataType:=xlDelimited, _
'      TextQualifier:=xlDoubleQuote, _
'      ConsecutiveDelimiter:=False, _
'      Tab:=False, Semicolon:=False, _
'      Comma:=False, Space:=False, _
'      Other:=True, OtherChar:="|"
'    x = x + 1
'
'    While x <= UBound(FilesToOpen)
'        Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
'        With wkbAll
'            wkbTemp.Sheets(1).Move After:=.Sheets(.Sheets.Count)
'            .Worksheets(x).Columns("A:A").TextToColumns _
'              Destination:=Range("A1"), DataType:=xlDelimited, _
'              TextQualifier:=xlDoubleQuote, _
'              ConsecutiveDelimiter:=False, _
'              Tab:=False, Semicolon:=False, _
'              Comma:=False, Space:=False, _
'              Other:=True, OtherChar:=sDelimiter
'        End With
'        x = x + 1
'    Wend

ExitHandler:
    Application.ScreenUpdating = True
    Set wkbAll = Nothing
    Set wkbTemp = Nothing
    Exit Sub

ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub

Code: Select all

Sub ImportTXTFiles()
    Dim fso As Object
    Dim xlsheet As Worksheet
    Dim qt As QueryTable
    Dim txtfilesToOpen As Variant, txtfile As Variant

    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")

    txtfilesToOpen = Application.GetOpenFilename _
                 (FileFilter:="Text Files (*.txt), *.txt", _
                  MultiSelect:=True, Title:="Text Files to Open")

    For Each txtfile In txtfilesToOpen
        ' FINDS EXISTING WORKSHEET
        For Each xlsheet In ThisWorkbook.Worksheets
            If xlsheet.Name = Replace(fso.GetFileName(txtfile), ".txt", "") Then
                xlsheet.Activate
                GoTo ImportData
            End If
        Next xlsheet

        ' CREATES NEW WORKSHEET IF NOT FOUND
        Set xlsheet = ThisWorkbook.Worksheets.Add( _
                             After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        xlsheet.Name = Replace(fso.GetFileName(txtfile), ".txt", "")
        xlsheet.Activate
        GoTo ImportData

ImportData:
        ' DELETE EXISTING DATA
        ActiveSheet.Range("A:Z").EntireColumn.Delete xlShiftToLeft

        ' IMPORT DATA FROM TEXT FILE
        With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & txtfile, _
          Destination:=ActiveSheet.Cells(1, 1))
            .TextFileParseType = xlDelimited
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = False
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = False
            .TextFilePlatform = 65001
            .TextFileDecimalSeparator = ","
            .TextFileOtherDelimiter = "|"

            .Refresh BackgroundQuery:=False
        End With

ActiveSheet.Range("A1").AutoFilter Field:=1, Visibledropdown:=True
ActiveSheet.Range("A1").AutoFilter Field:=2, Visibledropdown:=True

        For Each qt In ActiveSheet.QueryTables
            qt.Delete
        Next qt
    Next txtfile

    Application.ScreenUpdating = True
    MsgBox "Successfully imported text files!", vbInformation, "SUCCESSFUL IMPORT"

    Set fso = Nothing
End Sub

Code: Select all

Sub ImportTXTFiles()
    Dim fso As Object
    Dim xlsheet As Worksheet
    Dim qt As QueryTable
    Dim txtfilesToOpen As Variant, txtfile As Variant

    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")

    txtfilesToOpen = Application.GetOpenFilename _
                 (FileFilter:="Text Files (*.txt), *.txt", _
                  MultiSelect:=True, Title:="เลือกข้อมูลที่ต้องการนำเข้า By KiTTi")

    For Each txtfile In txtfilesToOpen
        ' FINDS EXISTING WORKSHEET
        For Each xlsheet In ThisWorkbook.Worksheets
            If xlsheet.Name = Replace(fso.GetFileName(txtfile), ".txt", "") Then
                xlsheet.Activate
                GoTo ImportData
            End If
        Next xlsheet

        ' CREATES NEW WORKSHEET IF NOT FOUND
        Set xlsheet = ThisWorkbook.Worksheets.Add( _
                             After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        xlsheet.Name = Replace(fso.GetFileName(txtfile), ".txt", "")
        xlsheet.Activate
        GoTo ImportData

ImportData:
        ' DELETE EXISTING DATA
        ActiveSheet.Range("A:Z").EntireColumn.Delete xlShiftToLeft

        ' IMPORT DATA FROM TEXT FILE
        With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & txtfile, _
          Destination:=ActiveSheet.Cells(1, 1))
            .TextFileParseType = xlDelimited
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = False
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = False
            .TextFilePlatform = 65001
            .TextFileOtherDelimiter = "|"

            .Refresh BackgroundQuery:=False
        End With

    ActiveSheet.Range("A1").AutoFilter Field:=1, Visibledropdown:=True
    ActiveSheet.Range("A1").AutoFilter Field:=2, Visibledropdown:=True

       Cells.Select
        Selection.NumberFormat = "0"
    
        For Each qt In ActiveSheet.QueryTables
            qt.Delete
        Next qt
    Next txtfile

    Application.ScreenUpdating = True
    MsgBox "นำข้อมูลเข้าสำเร็จแล้ว!", vbInformation, "สำเร็จแล้ว"

    Set fso = Nothing
End Sub

Code: Select all

On Error Resume Next