Snasui Excel Forum

Code: Select all

Dim x As Integer
    Dim wkbAll As Workbook
    Dim wkbTemp As Workbook
    Dim sDelimiter As String
    Dim rTarget As Range
    Dim r As Range
    
    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))
    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

Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
    Set wkbAll = ActiveWorkbook
        With wkbAll
            With Sheets(1)
                Set rTarget = .Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            End With
            
                 r.SpecialCells(xlCellTypeConstants).EntireRow.Copy
                 rTarget.PasteSpecial xlPasteValues
           
        End With

Code: Select all

Sub Import()
    Dim rTarget As Range
    Dim i As Integer
    Dim TextFileImport As Variant
    On Error GoTo MsgError
    TextFileImport = Application.GetOpenFilename("Text Files (*.txt),*.txt", , _
           "Select Text Data File", , True)
    For i = 1 To UBound(TextFileImport)
    Set rTarget = Worksheets("School").Range("C65536").End(xlUp).Offset(1, 0)
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & TextFileImport(i), _
        Destination:=rTarget)
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = False
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 874
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = True
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    Next i
    Exit Sub
MsgError:
    MsgBox "Please select a file"
    Exit Sub
End Sub

Code: Select all

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:="|"

Code: Select all

Sub Import()
    Dim rTarget As Range
    Dim i As Integer
    Dim TextFileImport As Variant
    On Error GoTo MsgError
    TextFileImport = Application.GetOpenFilename("Text Files (*.txt),*.txt", , _
           "Select Text Data File", , True)
    For i = 1 To UBound(TextFileImport)
    Set rTarget = Worksheets("Sheet1").Range("A65536").End(xlUp).Offset(1, 0)
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & TextFileImport(i), _
        Destination:=rTarget)
        .FieldNames = True
        'Other code
        .TextFileOtherDelimiter = "|" '<== Add this line
        .Refresh BackgroundQuery:=False
    End With
    Next i
    Exit Sub
MsgError:
    MsgBox "Please select a file"
    Exit Sub
End Sub

Code: Select all

Option Explicit
Sub CollectData()
    Dim sh As Worksheet, thisBook As Workbook, strThisbook As Variant
    Dim ob As Workbook, i As Integer, rRow As Long, tg As Range
    
    Set ob = ThisWorkbook
    ob.Sheets(1).UsedRange.Clear
    strThisbook = Application.GetOpenFilename(Filefilter:= _
            "All File (*.*), *.*", Title:="Please select source file(s).", MultiSelect:=True)
    If TypeName(strThisbook) = "Boolean" Then
        MsgBox "Please select file(s)."
        Exit Sub
    End If
    rRow = 1
    For i = 1 To UBound(strThisbook)
        Set thisBook = Workbooks.Open(strThisbook(i))
        Application.ScreenUpdating = False
        For Each sh In thisBook.Worksheets
            sh.UsedRange.Copy
            ob.Sheets(1).Range("a" & rRow).PasteSpecial xlPasteValues 'ตรงนี้ไม่ทำงาน
            rRow = ob.Sheets(1).UsedRange.Rows.Count + 1
            Application.CutCopyMode = False
        Next sh
        thisBook.Saved = True
        thisBook.Close
    Next i
    Application.ScreenUpdating = True
    MsgBox "Data already collected."
End Sub