รวมชีทจากแต่ละไฟล์ที่อยู่ในแต่ละ Subfolder

[niwat2811]

ต้องการรวมข้อมูลจากแต่ละชีทจาก D:/แยกรายภาค/ภาค 1, D:/แยกรายภาค/ภาค 2 จากทุก Subfolder มาต่อกันให้เป็นแต่ละไฟล์ใน
D:/สรุปภาค/ ตามตัวอย่างในไฟล์แนบครับ ไม่ทราบว่าควรปรับ Code อย่างไร Code อยู่ใน Module 1 ครับ

Code: Select all

Sub loopAllSubFolderSelectStartDirectory()

Call LoopAllSubFolders("D:\แยกรายภาค\")

End Sub
Sub LoopAllSubFolders(ByVal folderPath As String)

Dim fileName As String
Dim fullFilePath As String
Dim numFolders As Long
Dim folders() As String
Dim i As Long
Dim strThisOne As String
Dim strFile As String
Dim wbk As Workbook

If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
fileName = Dir(folderPath & "*.*", vbDirectory)

While Len(fileName) <> 0

    If Left(fileName, 1) <> "." Then
 
        fullFilePath = folderPath & fileName
 
        If (GetAttr(fullFilePath) And vbDirectory) = vbDirectory Then
            ReDim Preserve folders(0 To numFolders) As String
            folders(numFolders) = fullFilePath
            numFolders = numFolders + 1
        Else
             Set Wkb = Workbooks.Open(fileName:=folderPath & fileName)
             ActiveWorkbook.ActiveSheet.Copy After:=Workbooks("รวม.xlsm").Sheets(Workbooks("รวม.xlsm").Sheets.Count)
             ActiveWorkbook.Close
        End If
 
    End If
 
    fileName = Dir()

Wend

For i = 0 To numFolders - 1

    LoopAllSubFolders folders(i)
 
Next i

Call SaveMyWorkbook
Call Delete_Sheets

End Sub
Sub SaveMyWorkbook()
    Dim strThisOne As String
    Dim str As String
    Dim str1 As String
    Dim str2 As String
    Dim strFile As String
    Dim wbk As Workbook
    Dim Name As String
    Set wbk = ActiveWorkbook
    strThisOne = wbk.FullName
    Name = ActiveSheet.Name
    str = Right(Name, Len(Name) - InStr(Name, "ภาค") + 1)
    strFile = "D:\แยกรายภาค\" & str & ".xlsx"
    Application.DisplayAlerts = False
    wbk.Save
    wbk.SaveAs fileName:=strFile, FileFormat:=xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    'Workbooks.Open strThisOne
    Call Delete_Sheets
End Sub
Sub Delete_Sheets()
Dim i As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = Worksheets.Count To 2 Step -1
    Worksheets(i).Delete
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

[snasui]

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

[niwat2811]

ความต้องการคือ พอกดปุ่มรวมชีท มาโครจะทำการดึงข้อมูลจาก D:/แยกรายภาค/ภาค 1/ภาค 1.xlsx มาวางที่ไฟล์รวมโดยทำการต่อชีทกันไปเรื่อย ๆ ซึ่งปัญหาที่ติดขัดคือพอรันตัวมาโครแล้ว ดึงข้อมูลชีทมาแค่ไฟล์แรก แล้วขึ้น Popup (ภาพที่ 2) และไม่ยอมดึงข้อมูลชีทจากไฟล์อื่น ๆ มาครับ (ภาพที่ 3 คือภาพที่ควรจะดีงมาให้ครบ) เลยไม่ทราบว่าจะแก้ไขปรับปรุง Code อย่างไรครับ

[niwat2811]

ขออนุญาตแนบไฟล์เพิ่มเติมครับ

[snasui]

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

Code: Select all

Sub Example()
    Dim FileSystem As Object
    Dim HostFolder As String
    Dim subFolder As Object
    Dim fPath As String
    Dim file As Object
    Dim twb As Workbook
    Dim wb As Workbook
    Dim sh As Worksheet, scSh As Worksheet
    Dim tgS As Worksheet
    
    HostFolder = "D:\แยกรายภาค"
    fPath = "D:\สรุปภาค\"
    Set FileSystem = CreateObject("Scripting.FileSystemObject")

    For Each subFolder In FileSystem.getfolder(HostFolder).subfolders
        Select Case subFolder.Name
            Case "ภาค 1"
                Set twb = Workbooks.Open(fPath & "ภาค 1.xlsx")
            Case "ภาค 5"
                Set twb = Workbooks.Open(fPath & "ภาค 5.xlsx")
            Case "ภาค 10"
                Set twb = Workbooks.Open(fPath & "ภาค 10.xlsx")
            Case "ภาค 11"
                Set twb = Workbooks.Open(fPath & "ภาค 11.xlsx")
        End Select
        For Each file In subFolder.Files
            Set wb = Workbooks.Open(file)
            For Each sh In wb.Worksheets
                For Each scSh In twb.Worksheets
                    If scSh.Name = sh.Name Then
                        scSh.Cells.Copy sh.Range("a1")
                    End If
                Next scSh
            Next sh
            wb.Close False
        Next file
        twb.Close True
    Next subfolder
End Subb

[niwat2811]

Code สามารถใช้ได้ตรงตามต้องการ ขอบคุณมากครับ