Snasui Excel Forum

Posted: **Sun Jun 07, 2020 5:09 pm**

เรียนอาจารย์และพี่ๆเพื่อนๆสมาชิก
ผมลองนำ VBA Code ของอาจารย์มาใช้รวมข้อมูลจากหลายๆไฟล์แล้วขึ้น Eror ตามภาพตัวอย่างครับ โดยในแต่ล่ะ File จะมีอยู่หลายชีทแต่ต้องการข้อมูลจากชีทที่ชื่อ ColecData ของแต่ล่ะ File เท่านั้นมารวมกัน ช่วยแนะนำจุดที่ต้องปรับ Code เพิ่มเติมให้ผมหน่อยครับ

Sub CollectDataFromMultipleFiles()

    Dim wb As Workbook, s As Worksheet, db As Worksheet

    Dim strPath As Variant, i As Integer, f As Byte

    strPath = Application.GetOpenFilename( _

        FileFilter:="Excel File (*.xls*),*.xls*", _

        MultiSelect:=True)

    If TypeName(strPath) = "Boolean" Then Exit Sub

    Set db = ThisWorkbook.Sheets(1)

    db.UsedRange.ClearContents

    Application.ScreenUpdating = False

    For i = 1 To UBound(strPath)

        For Each s In wb.Worksheets

            f = IIf(db.Range("a1").Value = "", 1, 0)

            If s.Range("a1").Value <> "" Then

                s.UsedRange.Offset(f, 0).Copy

                With db

                    .Range("a" & .Rows.Count).End(xlUp).Offset(f, 0) _

                        .PasteSpecial xlPasteValues

                End With

            End If

        Next s

        wb.Close

        Application.CutCopyMode = False

    Next i

    Application.ScreenUpdating = True

    MsgBox "Finished", vbInformation

End Sub

Posted: **Mon Jun 08, 2020 7:14 pm**

กรุณาโพสต์ Code มาใหม่ให้มีรูปแบบที่เป็นไปตามกฎการใช้บอร์ดข้อ 5 ด้านบนพร้อมทั้งแนบไฟล์ Excel ที่เกิดปัญหานั้นมาด้วยครับ

Posted: **Mon Jun 08, 2020 9:50 pm**

snasui wrote: Mon Jun 08, 2020 7:14 pm กรุณาโพสต์ Code มาใหม่ให้มีรูปแบบที่เป็นไปตามกฎการใช้บอร์ดข้อ 5 ด้านบนพร้อมทั้งแนบไฟล์ Excel ที่เกิดปัญหานั้นมาด้วยครับ

ต้องการดึงข้อมูลA-E จากชีท CollecData ของแต่ล่ะไฟล์มารวมกันครับ ผมลองนำ Code ของอาจารย์มาลองใช้งานตอนรันขึ้น Run- time error 91 ครับ....File ที่ผมจะใช้รวมมันแนบมาไม่ได้ครับตอนแนบไฟล์มันขึ้นสถานะ "ลบ" code ที่ผมใช้ตามด้านล่างครับ file ข้อมูลตามที่แนบครับ

Code: Select all

Sub CollectDataFromMultipleFiles()
    Dim wb As Workbook, s As Worksheet, db As Worksheet
    Dim strPath As Variant, i As Integer, f As Byte
    strPath = Application.GetOpenFilename( _
        FileFilter:="Excel File (*.xls*),*.xls*", _
        MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    Set db = ThisWorkbook.Sheets(1)
    db.UsedRange.ClearContents
    Application.ScreenUpdating = False
    For i = 1 To UBound(strPath)
        For Each s In wb.Worksheets
            f = IIf(db.Range("a1").Value = "", 1, 0)
            If s.Range("a1").Value <> "" Then
                s.UsedRange.Offset(f, 0).Copy
                With db
                    .Range("a" & .Rows.Count).End(xlUp).Offset(f, 0) _
                        .PasteSpecial xlPasteValues
                End With
            End If
        Next s
        wb.Close
        Application.CutCopyMode = False
    Next i
    Application.ScreenUpdating = True
    MsgBox "Finished", vbInformation
End Sub

Posted: **Mon Jun 08, 2020 9:52 pm**

pro602 wrote: Mon Jun 08, 2020 9:50 pm
snasui wrote: Mon Jun 08, 2020 7:14 pm กรุณาโพสต์ Code มาใหม่ให้มีรูปแบบที่เป็นไปตามกฎการใช้บอร์ดข้อ 5 ด้านบนพร้อมทั้งแนบไฟล์ Excel ที่เกิดปัญหานั้นมาด้วยครับ
ต้องการดึงข้อมูลA-E จากชีท CollecData ของแต่ล่ะไฟล์มารวมกันครับ ผมลองนำ Code ของอาจารย์มาลองใช้งานตอนรันขึ้น Run- time error 91 ครับ....File ที่ผมจะใช้รวมมันแนบมาไม่ได้ครับตอนแนบไฟล์มันขึ้นสถานะ "ลบ" code ที่ผมใช้ตามด้านล่างครับ file ข้อมูลตามที่แนบครับ
Code: Select all
Sub CollectDataFromMultipleFiles()
    Dim wb As Workbook, s As Worksheet, db As Worksheet
    Dim strPath As Variant, i As Integer, f As Byte
    strPath = Application.GetOpenFilename( _
        FileFilter:="Excel File (*.xls*),*.xls*", _
        MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    Set db = ThisWorkbook.Sheets(1)
    db.UsedRange.ClearContents
    Application.ScreenUpdating = False
    For i = 1 To UBound(strPath)
        For Each s In wb.Worksheets
            f = IIf(db.Range("a1").Value = "", 1, 0)
            If s.Range("a1").Value <> "" Then
                s.UsedRange.Offset(f, 0).Copy
                With db
                    .Range("a" & .Rows.Count).End(xlUp).Offset(f, 0) _
                        .PasteSpecial xlPasteValues
                End With
            End If
        Next s
        wb.Close
        Application.CutCopyMode = False
    Next i
    Application.ScreenUpdating = True
    MsgBox "Finished", vbInformation
End Sub

file สำหรับรวมข้อมูลครับ

Posted: **Mon Jun 08, 2020 11:06 pm**

เขียน Code ไม่ครบครับ

ดูที่ผมทำสัญญลักษณ์ไว้ในภาพ และจำเป็นต้องตรวจสอบ Code ใหม่ในทุกบรรทัดให้ตรงกับในภาพครับ

Posted: **Tue Jun 09, 2020 6:36 am**

snasui wrote: Mon Jun 08, 2020 11:06 pm เขียน Code ไม่ครบครับ

ดูที่ผมทำสัญญลักษณ์ไว้ในภาพ และจำเป็นต้องตรวจสอบ Code ใหม่ในทุกบรรทัดให้ตรงกับในภาพครับ

หลังจากที่ผมได้ปรับCode ตามที่อาจารย์แนะนำแล้วทดลองรันผลข้อมูลที่ดึงมาจะได้ข้อมูลจากทุกชีทของFile มาเพียงแค่ Fileเดียวครับ(ระหว่างรันโปรแกรมมีข้อความขึ้นตามรูปที่แนบครับ) ไม่มาทุกFile
ผมต้องปรับCode ตรงจุดไหนครับเพื่อให้ข้อมูลที่ดึงมารวมกัน เอาเฉพาะข้อมูลจากชีท CollecData ของทุกFile
Code ที่ปรับแล้วตามที่อาจารย์แนะนำให้ไปตรวจสอบเพิ่มเติม

Code: Select all

Sub CollectDataFromMultipleFiles()
    Dim wb As Workbook, s As Worksheet, db As Worksheet
    Dim strPath As Variant, i As Integer, f As Byte
    strPath = Application.GetOpenFilename( _
        FileFilter:="Excel File (*.xls*),*.xls*", _
        MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    Set db = ThisWorkbook.Sheets(1)
    db.UsedRange.ClearContents
    Application.ScreenUpdating = False
    For i = 1 To UBound(strPath)
         Set wb = Workbooks.Open(strPath(1))
        For Each s In wb.Worksheets
            f = IIf(db.Range("a1").Value = "", 1, 0)
            If s.Range("a1").Value <> "" Then
                s.UsedRange.Offset(f, 0).Copy
                With db
                    .Range("a" & .Rows.Count).End(xlUp).Offset(f, 0) _
                        .PasteSpecial xlPasteValues
                End With
            End If
        Next s
        wb.Close False
        Application.CutCopyMode = False
    Next i
    Application.ScreenUpdating = True
    MsgBox "Finished", vbInformation
End Sub

Posted: **Tue Jun 09, 2020 12:27 pm**

pro602 wrote: Tue Jun 09, 2020 6:36 am
snasui wrote: Mon Jun 08, 2020 11:06 pm เขียน Code ไม่ครบครับ

ดูที่ผมทำสัญญลักษณ์ไว้ในภาพ และจำเป็นต้องตรวจสอบ Code ใหม่ในทุกบรรทัดให้ตรงกับในภาพครับ

หลังจากที่ผมได้ปรับCode ตามที่อาจารย์แนะนำแล้วทดลองรันผลข้อมูลที่ดึงมาจะได้ข้อมูลจากทุกชีทของFile มาเพียงแค่ Fileเดียวครับ(ระหว่างรันโปรแกรมมีข้อความขึ้นตามรูปที่แนบครับ) ไม่มาทุกFile
ผมต้องปรับCode ตรงจุดไหนครับเพื่อให้ข้อมูลที่ดึงมารวมกัน เอาเฉพาะข้อมูลจากชีท CollecData ของทุกFile
Code ที่ปรับแล้วตามที่อาจารย์แนะนำให้ไปตรวจสอบเพิ่มเติม
Code: Select all
Sub CollectDataFromMultipleFiles()
    Dim wb As Workbook, s As Worksheet, db As Worksheet
    Dim strPath As Variant, i As Integer, f As Byte
    strPath = Application.GetOpenFilename( _
        FileFilter:="Excel File (*.xls*),*.xls*", _
        MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    Set db = ThisWorkbook.Sheets(1)
    db.UsedRange.ClearContents
    Application.ScreenUpdating = False
    For i = 1 To UBound(strPath)
         Set wb = Workbooks.Open(strPath(1))
        For Each s In wb.Worksheets
            f = IIf(db.Range("a1").Value = "", 1, 0)
            If s.Range("a1").Value <> "" Then
                s.UsedRange.Offset(f, 0).Copy
                With db
                    .Range("a" & .Rows.Count).End(xlUp).Offset(f, 0) _
                        .PasteSpecial xlPasteValues
                End With
            End If
        Next s
        wb.Close False
        Application.CutCopyMode = False
    Next i
    Application.ScreenUpdating = True
    MsgBox "Finished", vbInformation
End Sub

Code: Select all

Sub CollectDataFromMultipleFiles()
    Dim wb As Workbook, s As Worksheet, db As Worksheet
    Dim strPath As Variant, i As Integer, f As Byte
    strPath = Application.GetOpenFilename( _
        FileFilter:="Excel File (*.xls*),*.xls*", _
        MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    Set db = ThisWorkbook.Sheets(1)
    db.UsedRange.ClearContents
    Application.ScreenUpdating = False
    For i = 1 To UBound(strPath)
         Set wb = Workbooks.Open(strPath(i)) '<<<ตรงนี้เปลี่ยนเป็น i ตามอาจารย์แจ้งครับ
        For Each s In wb.Worksheets
            f = IIf(db.Range("a1").Value = "", 1, 0)
            If s.Range("a1").Value <> "" Then
                s.UsedRange.Offset(f, 0).Copy
                With db
                    .Range("a" & .Rows.Count).End(xlUp).Offset(f, 0) _
                        .PasteSpecial xlPasteValues
                End With
            End If
        Next s
        wb.Close False
        Application.CutCopyMode = False
    Next i
    Application.ScreenUpdating = True
    MsgBox "Finished", vbInformation
End Sub

Posted: **Tue Jun 09, 2020 1:44 pm**

Code: Select all

Sub CollectDataFromMultipleFiles()
    Dim wb As Workbook, s As Worksheet, db As Worksheet
    Dim strPath As Variant, i As Integer, f As Byte
    strPath = Application.GetOpenFilename( _
        FileFilter:="Excel File (*.xls*),*.xls*", _
        MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    Set db = ThisWorkbook.Sheets(1)
    db.UsedRange.ClearContents
    Application.ScreenUpdating = False
    For i = 1 To UBound(strPath)
         Set wb = Workbooks.Open(strPath(i))
        For Each s In wb.Worksheets
            f = IIf(db.Range("a1").Value = "", 1, 0)
            If s.Range("a1").Value <> "" Then
                s.UsedRange.Offset(f, 0).Copy
                With db
                    .Range("a" & .Rows.Count).End(xlUp).Offset(f, 0) _
                        .PasteSpecial xlPasteValues
                End With
            End If
        Next s
        wb.Close False
        Application.CutCopyMode = False
    Next i
    Application.ScreenUpdating = True
    MsgBox "Finished", vbInformation
End Sub

[/quote]
ผมก็๋ลองเปลี่ยนเป็น i ไปแล้วครับ ผลที่ได้ก็คือจะมีข้อมูลมาจากทุกชีทของ File Line 4 เพียง File เดียวครับ (ตามที่ผมแนบ Fileมาในตอนต้น Line4,Line5,Line6)
จากปัญหาที่เกิดขึ้นผมต้องปรับ Code ตรงจุดไหนเพิ่มเติมครับเพื่อให้ได้ข้อมูลที่มาจากชีท CollecData ของทุก File มารวมต่อกันครับ...

Posted: **Tue Jun 09, 2020 2:21 pm**

ลองปรับตามนี้ แต่ไฟล์ต้นทาง ต้องตัดค่าบรรทัดที่มีค่าว่างออกด้วย ไม่นั้นข้อมูลจะต่อกันห่างกันครับ

Code: Select all

Sub CollectDataFromMultipleFiles()
    Dim wb As Workbook, s As Worksheet, db As Worksheet
    Dim strPath As Variant, i As Integer, f As Byte
    Application.DisplayAlerts = False
    strPath = Application.GetOpenFilename( _
        FileFilter:="Excel File (*.xls*),*.xls*", _
        MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    Set db = ThisWorkbook.Sheets(1)
    db.UsedRange.ClearContents
    Application.ScreenUpdating = False
    For i = 1 To UBound(strPath)
         Set wb = Workbooks.Open(strPath(i))
     '   For Each s In wb.Worksheets
         Set s = wb.Sheets("CollecData")
            f = IIf(db.Range("a1").Value = "", 1, 0)
            If s.Range("a1").Value <> "" Then
                s.UsedRange.Offset(f, 0).Copy
                With db
                    .Range("a" & .Rows.Count).End(xlUp).Offset(f, 0) _
                        .PasteSpecial xlPasteValues
                End With
            End If
      '  Next s
        wb.Close False
        Application.CutCopyMode = False
    Next i
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Finished", vbInformation
End Sub

Posted: **Tue Jun 09, 2020 4:56 pm**

puriwutpokin wrote: Tue Jun 09, 2020 2:21 pm ลองปรับตามนี้ แต่ไฟล์ต้นทาง ต้องตัดค่าบรรทัดที่มีค่าว่างออกด้วย ไม่นั้นข้อมูลจะต่อกันห่างกันครับ

Code: Select all

Sub CollectDataFromMultipleFiles()
    Dim wb As Workbook, s As Worksheet, db As Worksheet
    Dim strPath As Variant, i As Integer, f As Byte
    Application.DisplayAlerts = False
    strPath = Application.GetOpenFilename( _
        FileFilter:="Excel File (*.xls*),*.xls*", _
        MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    Set db = ThisWorkbook.Sheets(1)
    db.UsedRange.ClearContents
    Application.ScreenUpdating = False
    For i = 1 To UBound(strPath)
         Set wb = Workbooks.Open(strPath(i))
     '   For Each s In wb.Worksheets
         Set s = wb.Sheets("CollecData")
            f = IIf(db.Range("a1").Value = "", 1, 0)
            If s.Range("a1").Value <> "" Then
                s.UsedRange.Offset(f, 0).Copy
                With db
                    .Range("a" & .Rows.Count).End(xlUp).Offset(f, 0) _
                        .PasteSpecial xlPasteValues
                End With
            End If
      '  Next s
        wb.Close False
        Application.CutCopyMode = False
    Next i
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Finished", vbInformation
End Sub

ขอบคุณครับสำหรับแนวทาง Code หลังจากที่ผมได้ทดลองนำมาใช้รันโปรแกรม สามารถดึงข้อมูลมาจาก Sheet CollecData เพียงชีทเดียวตามที่ต้องการครับแต่จะได้ข้อมูลเพียงแค่ไฟล์เดียวอยู่ครับ น่าจะเกิดจากการวางทับที่เดิมเราจะปรับให้วิ่งไปวางต่อที่ Row สุดท้ายตรงไหนครับ

Posted: **Tue Jun 09, 2020 5:18 pm**

pro602 wrote: Tue Jun 09, 2020 4:56 pm
puriwutpokin wrote: Tue Jun 09, 2020 2:21 pm ลองปรับตามนี้ แต่ไฟล์ต้นทาง ต้องตัดค่าบรรทัดที่มีค่าว่างออกด้วย ไม่นั้นข้อมูลจะต่อกันห่างกันครับ
Code: Select all
Sub CollectDataFromMultipleFiles()
    Dim wb As Workbook, s As Worksheet, db As Worksheet
    Dim strPath As Variant, i As Integer, f As Byte
    Application.DisplayAlerts = False
    strPath = Application.GetOpenFilename( _
        FileFilter:="Excel File (*.xls*),*.xls*", _
        MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    Set db = ThisWorkbook.Sheets(1)
    db.UsedRange.ClearContents
    Application.ScreenUpdating = False
    For i = 1 To UBound(strPath)
         Set wb = Workbooks.Open(strPath(i))
     '   For Each s In wb.Worksheets
         Set s = wb.Sheets("CollecData")
            f = IIf(db.Range("a1").Value = "", 1, 0)
            If s.Range("a1").Value <> "" Then
                s.UsedRange.Offset(f, 0).Copy
                With db
                    .Range("a" & .Rows.Count).End(xlUp).Offset(f, 0) _
                        .PasteSpecial xlPasteValues
                End With
            End If
      '  Next s
        wb.Close False
        Application.CutCopyMode = False
    Next i
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Finished", vbInformation
End Sub
ขอบคุณครับสำหรับแนวทาง Code หลังจากที่ผมได้ทดลองนำมาใช้รันโปรแกรม สามารถดึงข้อมูลมาจาก Sheet CollecData เพียงชีทเดียวตามที่ต้องการครับแต่จะได้ข้อมูลเพียงแค่ไฟล์เดียวอยู่ครับ น่าจะเกิดจากการวางทับที่เดิมเราจะปรับให้วิ่งไปวางต่อที่ Row สุดท้ายตรงไหนครับ

ที่ไฟล์ที่ดึงค่ามา ใช้ UsedRange ทำให้เอาค่าว่างที่มีค่าแอบแฝงมาด้วยครับลองลบบรรทัดไฟล์ต้นทางแถวสุดท้ายลงโดยกด Ctrl+Shift+ลูกศรชี้ลงแล้วกดลบแถวดูครับไปทั้งสามไฟล์แล้วรันใหม่ดูครับ

Posted: **Tue Jun 09, 2020 9:02 pm**

puriwutpokin wrote: Tue Jun 09, 2020 5:18 pm
pro602 wrote: Tue Jun 09, 2020 4:56 pm
puriwutpokin wrote: Tue Jun 09, 2020 2:21 pm ลองปรับตามนี้ แต่ไฟล์ต้นทาง ต้องตัดค่าบรรทัดที่มีค่าว่างออกด้วย ไม่นั้นข้อมูลจะต่อกันห่างกันครับ
Code: Select all
Sub CollectDataFromMultipleFiles()
    Dim wb As Workbook, s As Worksheet, db As Worksheet
    Dim strPath As Variant, i As Integer, f As Byte
    Application.DisplayAlerts = False
    strPath = Application.GetOpenFilename( _
        FileFilter:="Excel File (*.xls*),*.xls*", _
        MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    Set db = ThisWorkbook.Sheets(1)
    db.UsedRange.ClearContents
    Application.ScreenUpdating = False
    For i = 1 To UBound(strPath)
         Set wb = Workbooks.Open(strPath(i))
     '   For Each s In wb.Worksheets
         Set s = wb.Sheets("CollecData")
            f = IIf(db.Range("a1").Value = "", 1, 0)
            If s.Range("a1").Value <> "" Then
                s.UsedRange.Offset(f, 0).Copy
                With db
                    .Range("a" & .Rows.Count).End(xlUp).Offset(f, 0) _
                        .PasteSpecial xlPasteValues
                End With
            End If
      '  Next s
        wb.Close False
        Application.CutCopyMode = False
    Next i
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Finished", vbInformation
End Sub
ขอบคุณครับสำหรับแนวทาง Code หลังจากที่ผมได้ทดลองนำมาใช้รันโปรแกรม สามารถดึงข้อมูลมาจาก Sheet CollecData เพียงชีทเดียวตามที่ต้องการครับแต่จะได้ข้อมูลเพียงแค่ไฟล์เดียวอยู่ครับ น่าจะเกิดจากการวางทับที่เดิมเราจะปรับให้วิ่งไปวางต่อที่ Row สุดท้ายตรงไหนครับ
ที่ไฟล์ที่ดึงค่ามา ใช้ UsedRange ทำให้เอาค่าว่างที่มีค่าแอบแฝงมาด้วยครับลองลบบรรทัดไฟล์ต้นทางแถวสุดท้ายลงโดยกด Ctrl+Shift+ลูกศรชี้ลงแล้วกดลบแถวดูครับไปทั้งสามไฟล์แล้วรันใหม่ดูครับ

ผมทดลองตามคำแนะนำแล้วได้ผลตามที่ต้องการเลยครับ...ขอบคุณมากๆครับ
ผมเดี๋ยวผมจะลองหาวิธีลบค่าว่างของข้อมูลต้นทางอีกทีครับ

Snasui Excel Forum

รวมข้อมูลจากหลายไฟล์

รวมข้อมูลจากหลายไฟล์

Re: รวมข้อมูลจากหลายไฟล์

Re: รวมข้อมูลจากหลายไฟล์

Re: รวมข้อมูลจากหลายไฟล์

Re: รวมข้อมูลจากหลายไฟล์

Re: รวมข้อมูลจากหลายไฟล์

Re: รวมข้อมูลจากหลายไฟล์

Re: รวมข้อมูลจากหลายไฟล์

Re: รวมข้อมูลจากหลายไฟล์

Re: รวมข้อมูลจากหลายไฟล์

Re: รวมข้อมูลจากหลายไฟล์

Re: รวมข้อมูลจากหลายไฟล์