รวม ไฟล์ .txt หลาย ๆ ไฟล์ไว้ใน Sheets เดียว

[akung]

ผมลองทำแล้ว สามารถเปิดไฟล์ได้ครับตามที่เราเลือก แต่จะติดปัญหา ไฟล์ที่ 2 จะ Error คือ พอเปิดไฟล์ที่ 1 ได้แล้ว สร้างไฟล์ใหม่และทำ Copy ไฟล์ .txt ไปไว้ในไฟล์ใหม่แล้ว แต่พอเปิด .txt ไฟล์ที่ 2 มันกับฟ้อง Error รบกวนด้วยครับ ขอบคุณครับ

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

[snasui]

แนบไฟล์ตัวอย่างมาด้วยเพื่อจะได้ช่วยทดสอบได้ครับ

[akung]

แนบไฟล์ตัวอย่างมาด้วยเพื่อจะได้ช่วยทดสอบได้ครับ

อัพไฟล์ให้แล้วครับ รบกวนอาจารย์ด้วยครับ

ผมอัพไฟล์ .txt ไม่ผ่าน ครับ

ไฟล์ .txt ผมใช้ notepad ครับ คีย์ แค่ 3 ฟิลด์ คือ

ไฟล์ที่ 1 ชื่อ Test1.txt
นาย ก. สมส่วน 100
นาย ข. สมใจ 200

ไฟล์ที่ 2 ชื่อ Test2.txt
นาย ค. แซ่ตั้ง 300
นาย ง. แซ่ลี้ 400

[snasui]

Code สำหรับรวม Text File ดูที่นี่เป็นตัวอย่างครับ viewtopic.php?f=3&t=309#p1661

[akung]

Code สำหรับรวม Text File ดูที่นี่เป็นตัวอย่างครับ viewtopic.php?f=3&t=309#p1661

จาก Code ผมพยายามแก้ไข Column เริ่มต้น เพราะจาก Code มันให้เริ่มต้นที่ Column C แถวที่ 2 แต่ผมต้องการให้เริ่มที่ Column A แถวที่ 2 ครับต้องแก้ตรงไหนครับ

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

[snasui]

แก้ตรง Set rTarget = Worksheets("School").Range("C65536").End(xlUp).Offset(1, 0) เป็น Set rTarget = Worksheets("School").Range("A65536").End(xlUp).Offset(1, 0) ครับ

[akung]

แก้ตรง Set rTarget = Worksheets("School").Range("C65536").End(xlUp).Offset(1, 0) เป็น Set rTarget = Worksheets("School").Range("A65536").End(xlUp).Offset(1, 0) ครับ

ขอบคุณครับอาจารย์ เส้นผมบังภูเขาจริง ๆ

[akung]

ขออนุญาติรบกวนอาจารย์อีกครั้งครับ คือ .txt ไำฟล์ที่ได้ มีตัว | เป็นตัวคั่นอยู่ จึงอยากต้องการให้ฟิลด์แยกตาม ตัว | ต้องเขียนอย่างไรครับผมใช้ Code นี้แต่ก็ ไม่ผ่านครับ

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

[snasui]

ลองดูตัวอย่าง code ตามด้านล่างครับ

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

[akung]

ขอบคุณอาจารย์มาก ๆ ครับ

[akung]

รบกวนอาจารย์เพิ่มเติมครับ ถ้าผมต้องการเปลี่ยนการรวมไฟล์จาก .txt เป็น xls จะต้องทำเปลี่ยนคำสั่งอะไรบ้างครับ ขอบคุณครับ

[snasui]

ลองดูตัวอย่างจากโพสต์นี้ครับ viewtopic.php?f=3&t=6593#p42201

[akung]

ขอบคุณอาจารย์มากครับ

แต่จาการตรวจเช็คโปรแกรม ระบบทำการเปิดไฟล์ขึ้นมาตามที่เลือก และมีการ Copy ข้อมูลถูกต้อง แต่พอตอนที่จะมาวางเหมือนคำสั่งมันโดดข้ามไปยอมวาง ไม่ทราบว่าเป็นเพราะอะไร รบกวนอาจารย์ด้วยครับ

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

[snasui]

แนบไฟล์ตัวอย่างมาด้วยเพื่อเพื่อน ๆ จะได้ช่วยทดสอบได้ครับ

[akung]

จากการทดสอบอีกครั้ง ผมฝั่งคำสั่งไว้ใน This Workbook สรุปว่าคำสั่งใช้งานได้อย่างถูกต้องครับ

แต่ตอนแรกที่ทดสอบผมนำคำสั่งไปฝั่งไว้ที่ Personal Marco Workbook คำสั่งทำงานไม่ครบตามที่แจ้งครับ ตอนนี้กำลังหาสาเหตุอยู่ครับ