merge file ด้วย VBA

[nilrop]

ติดปัญหาอีกนิดนึงค่ะ ถ้าหากว่า ข้อมูลจริงๆจนถึงบรรทัดสุดท้ายของแต่ละไฟล์นั้นอยู่ที่คอลัมน์ S แต่ข้อมูลทั้งหมดยาวไปจนถึงคอลัมน์ Q จะใช้คอลัมน์ไหนอ้างอิงคะ

พอเปลี่ยนเป็น S ก็ดึงให้หมดจนบรรทัดสุดท้ายจริง แต่ก็สิ้นสุดที่ S ส่วนข้อมูลในคอลัมน์ที่เหลือถึง Q ไม่ดึงมาให้

พอเปลี่ยนเป็น Q ก็ดึงข้อมูลให้หมดจนถึงคอลัมน์ Q แต่บรรทัดสุดท้ายที่อยู่ที่คอลัมน์ S ไม่ถูกเอามาด้วย

ควรแก้ code ยังไงดีคะ

[nilrop]

ลืมแนบไฟล์ตัวอย่างค่ะ

[nilrop]

เอ่อ ไม่แน่ใจว่าทำอะไรผิดกฎไหม แต่ได้ลองไปหาคำตอบเอาเองแล้ว ก็ยังจนปัญญาอยู่ดีค่ะ ยังไม่สามารถรวมไฟล์จนถึงบรรทัดสุดท้ายได้จริงๆเลยค่ะ รบกวนผู้รู้ชี้แนะอีกครั้งค่ะ:oops:

ป.ล. อีกปัญหานึง เวลาบันทึกสูตรลง macro เช่น =B2 แล้ว ตอน run macro กลับขึ้นเป็น =RC[-1] แทน เพราะสาเหตุอะไรเหรอคะ งงค่ะ

ขอบคุณมากๆๆค่ะที่ช่วยเหลือ

[snasui]

ติดปัญหาอีกนิดนึงค่ะ ถ้าหากว่า ข้อมูลจริงๆจนถึงบรรทัดสุดท้ายของแต่ละไฟล์นั้นอยู่ที่คอลัมน์ S แต่ข้อมูลทั้งหมดยาวไปจนถึงคอลัมน์ Q จะใช้คอลัมน์ไหนอ้างอิงคะ

พอเปลี่ยนเป็น S ก็ดึงให้หมดจนบรรทัดสุดท้ายจริง แต่ก็สิ้นสุดที่ S ส่วนข้อมูลในคอลัมน์ที่เหลือถึง Q ไม่ดึงมาให้

พอเปลี่ยนเป็น Q ก็ดึงข้อมูลให้หมดจนถึงคอลัมน์ Q แต่บรรทัดสุดท้ายที่อยู่ที่คอลัมน์ S ไม่ถูกเอามาด้วย

ควรแก้ code ยังไงดีคะ

ที่อธิบายมานี้คอลัมน์ S และ Q คอลัมน์ไหนอยู่ก่อนหรืออยู่หลัง ลองทบทวนแล้วอธิบายมาใหม่ครับ

[nilrop]

ที่อธิบายมานี้คอลัมน์ S และ Q คอลัมน์ไหนอยู่ก่อนหรืออยู่หลัง ลองทบทวนแล้วอธิบายมาใหม่ครับ

ว้าย ขอโทษค่ะ เขียนผิด สับสนไปหน่อย อายจัง

ตามรูปนี้ บรรทัดสุดท้ายสิ้นสุดที่ M ส่วนคอลัมน์สุดท้ายอยู่ที่ Q ค่ะ

[img][img]http://upic.me/i/4o/va5lp.jpg[/img][/img]

[niwat2811]

ลองปรับโค๊ดเป็นแบบนี้ดูครับ ว่าใช้ได้ตามต้องการไหม

Code: Select all

Sub simpleXlsMerger4()
    
    Dim bookList As Workbook
    Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
    
    Application.ScreenUpdating = False
    Set mergeObj = CreateObject("Scripting.FileSystemObject")
     
    Set dirObj = mergeObj.Getfolder(Sheets("Sheet4").Range("A1"))
    Set filesObj = dirObj.Files
    For Each everyObj In filesObj
        Set bookList = Workbooks.Open(everyObj)
        bookList.Sheets(1).Range("A1:Q" & bookList.Sheets(1).Range("I65536").End(xlUp).Row).Copy
        ThisWorkbook.Worksheets(3).Activate
        If Range("Q65536").End(xlUp).Offset(1, -16).Row = 1 Then
            Range("a1").PasteSpecial
        Else
            Range("Q65536").End(xlUp).Offset(2, -16).PasteSpecial
        End If
        Application.CutCopyMode = False
        bookList.Close False
    Next
    Application.ScreenUpdating = True
End Sub

[nilrop]

ลองปรับโค๊ดเป็นแบบนี้ดูครับ ว่าใช้ได้ตามต้องการไหม

Code: Select all

Sub simpleXlsMerger4()
    
    Dim bookList As Workbook
    Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
    
    Application.ScreenUpdating = False
    Set mergeObj = CreateObject("Scripting.FileSystemObject")
     
    Set dirObj = mergeObj.Getfolder(Sheets("Sheet4").Range("A1"))
    Set filesObj = dirObj.Files
    For Each everyObj In filesObj
        Set bookList = Workbooks.Open(everyObj)
        bookList.Sheets(1).Range("A1:Q" & bookList.Sheets(1).Range("I65536").End(xlUp).Row).Copy
        ThisWorkbook.Worksheets(3).Activate
        If Range("Q65536").End(xlUp).Offset(1, -16).Row = 1 Then
            Range("a1").PasteSpecial
        Else
            Range("Q65536").End(xlUp).Offset(2, -16).PasteSpecial
        End If
        Application.CutCopyMode = False
        bookList.Close False
    Next
    Application.ScreenUpdating = True
End Sub

ลองแล้วยังไม่ได้ค่ะ บรรทัดสุดท้ายไม่ยอมมา ลองเปลี่ยนจาก

Code: Select all

Range("I65536")

เป็น

Code: Select all

Range("M65536")

ก็ยังไม่สำเร็จค่ะ

[snasui]

ตัวอย่าง Code ครับ

Code: Select all

Sub simpleXlsMerger4()

    Dim bookList As Workbook
    Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
    
    Application.ScreenUpdating = False
    
    Set mergeObj = CreateObject("Scripting.FileSystemObject")
    Set dirObj = mergeObj.Getfolder(Sheets("Sheet4").Range("A1"))
    Set filesObj = dirObj.Files
    
    For Each everyObj In filesObj
        Set bookList = Workbooks.Open(everyObj)
        bookList.Sheets(1).Range("A1:Q" & bookList.Sheets(1).Range("M65536").End(xlUp).Row).Copy
        ThisWorkbook.Worksheets(3).Activate
            If Range("M65536").End(xlUp).Row = 1 Then
                Range("a1").PasteSpecial
            Else
                Range("M65536").End(xlUp).Offset(1, -12).PasteSpecial
            End If
            Application.CutCopyMode = False
            bookList.Close False
    Next
    
    Application.ScreenUpdating = True

End Sub

[nilrop]

มารายงานผลค่ะ ได้ตามที่ต้องการ ขอบคุณมากๆๆนะคะที่ให้คำแนะนำ

ป.ล. อีกปัญหานึง เวลาบันทึกสูตรลง macro เช่น =B2 แล้ว ตอน run macro กลับขึ้นเป็น =RC[-1] แทน เพราะสาเหตุอะไรเหรอคะ งงค่ะ

อันนี้ยังงงอยู่เลยค่ะ

[snasui]

อยู่ที่การกำหนดค่า Relative References ตามภาพด้านล่างครับ

[nilrop]

อยู่ที่การกำหนดค่า Relative References ตามภาพด้านล่างครับ

อ้ออย่างนี้นี่เอง สงสัยมือไปกดโดนค่ะ ไม่ได้ตั้งใจจะกำหนดแบบนี้เลย ขอบคุณมากเลยค่ะ