Excel Forum

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

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