Loop Sub Folder

parakorn · #1

เรียนอาจารย์ และ เพื่อนๆในบอร์ดครับ

เนื่องจากผมต้องการ Loop เข้าไปใน Folder เรื่อยๆ จนกว่าจะเจอไฟล์ Excel ที่มีชื่อขึ้นต้นว่า "FINAL COST" แล้วทำการ Debug ทุกไฟล์ ซึ่งแต่ละ Folder ก็มี Folder ซ้อนเข้าไปเรื่อยๆ แต่ล่ะ Folder ก็มีจำนวนที่ซ้อนเข้าไปไม่เท่ากัน อยากทราบว่าต้องการแก้ไขโค้ดอย่างไรให้สามารถทำงานได้ครับ

Code: Select all

Public Sub NonRecursiveMethod()
    Dim fso, oFolder, oSubfolder, oFile, queue As Collection

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set queue = New Collection
    queue.Add fso.GetFolder("D:\Detail\wetransfer_2022-1-zip_2022-10-25_1306\")
    Do While queue.Count > 0
        Set oFolder = queue(1)
        queue.Remove 1 'dequeue
            For Each oSubfolder In oFolder.SubFolders
                queue.Add oSubfolder 'enqueue
            Next oSubfolder
        For Each oFile In oFolder.Files
          oFile = Dir("*FINAL COST*")
                Do While Len(oFile) > 0
                Debug.Print
                Loop
        Next oFile
    Loop
End Sub

snasui · #2

กรุณาแนบไฟล์ตัวอย่างประกอบเพื่อสะดวกต่อการตอบของเพื่อนสมาชิกครับ

parakorn · #3

เรียนอาจารย์ครับ
ในโฟล์เดอร์สุดท้าย บางโฟล์เดอร์มี 2 โฟล์ที่ต้องการ แต่ตอนนี้มัน Return แค่ไฟล์เดียวครับ
ขอบคุณมากครับ

Code: Select all

Sub sample2()
    Dim FileSystem As Object
    Dim HostFolder As String

    HostFolder = "D:\Detail\wetransfer_2022-1-zip_2022-10-25_1306\"

    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder2 FileSystem.GetFolder(HostFolder)
End Sub

Sub DoFolder2(Folder)
    Dim SubFolder
    For Each SubFolder In Folder.SubFolders
        If found Then Exit For
        DoFolder2 SubFolder
    Next
    Dim File
    Dim n As Long
    For Each File In Folder.Files
        If found Then Exit For
            'for each InFile in Folder.File
                If Left(File.Name, 10) = "FINAL COST" Then
                    found = True
                        n = Range("A" & Rows.Count).End(xlUp).Row
                        Sheets("Sheet1").Range("B" & n + 1) = Folder.Name
                        Sheets("Sheet1").Range("A" & n + 1) = File.Name
                End If
            'Next
    Next
End Sub

snasui · #4

ปลดตัวดักการออกจาก Loop ทิ้งไป ตัวอย่างการปรับ Code ตามด้านล่างครับ

Code: Select all

'Other code
Sub DoFolder2(Folder)
    Dim SubFolder, File
    Dim n As Long
    
    For Each SubFolder In Folder.SubFolders
        DoFolder2 SubFolder
    Next

    For Each File In Folder.Files
        If Left(File.Name, 10) = "FINAL COST" Then
            n = Range("A" & Rows.Count).End(xlUp).Row
            Sheets("Sheet1").Range("B" & n + 1) = Folder.Name
            Sheets("Sheet1").Range("A" & n + 1) = File.Name
        End If
    Next
End Sub

parakorn · #5

ได้ล่ะครับอาจารย์ รบกวนสอบถามต่อเลยนะครับ หากต้องการ Loop เข้าไปในแต่ล่ะชีท ของแต่ล่ะไฟล์ โดยไม่ต้องการเปิดไฟล์(ไฟล์มีจำนวนเยอะมากๆ) แล้ว Return Result ออกมาต้องปรับโค้ดประมาณไหนครับ
- ในแต่ล่ะไฟล์ ต้องการ Loop เฉพาะ Sheets ที่มีชื่อ 10ตัวแรก = "COST SHEET"
- ต้องการ Return ข้อมูลตั้งแต่ A10 ไปจนถึง Column และ Row สุดท้ายของไฟล์ (Use Range) นำมาต่อๆกันโดยที่ไม่ต้อง Transpose ครับ(เอา Head มาด้วยเพราะต้องการ Reconsign Head ด้วยครับ)

ตัวอย่างข้อมูลตามไฟลแนบครับ

Code: Select all

Sub sample2()
    Dim FileSystem As Object
    Dim HostFolder As String

    HostFolder = "D:\Detail\wetransfer_2022-1-zip_2022-10-25_1306\"

    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder2 FileSystem.GetFolder(HostFolder)
End Sub

Sub DoFolder2(Folder)
    Dim SubFolder
    For Each SubFolder In Folder.SubFolders
        DoFolder2 SubFolder
    Next
    Dim File
    Dim n As Long
    Dim n2 As Long
    Dim sh As Worksheet
    Dim tws As Workbook
    For Each File In Folder.Files
                If Left(File.Name, 10) = "FINAL COST" Then
                    found = True
                            n = Sheets("List").Range("A" & Rows.Count).End(xlUp).Row
                            n2 = Sheets("Detail1").Range("C" & Rows.Count).End(xlUp).Row
                            Sheets("List").Range("B" & n + 1) = Folder.Name
                            Sheets("List").Range("A" & n + 1) = File.Name
                            'myfile = Dir(File)
'                            ws = File.Workbook
                                For Each sh In tws
                                    If Left(sh.Name, 10) = "FINAL COST" Then
                                    Sheets("Detail1").Range("C" & n2 + 1) = Range("A12:AW12").Value
                                    End If
                                Next
'                                    With Workbooks(File)
'                                        If Left(sh.Name, 10) = "FINAL COST" Then
'                                        Sheets("Detail1").Range("C" & n2 + 1) = Range("A12:AW12").Value
'                                         End If
'                                    End With
                End If
    Next
End Sub

snasui · #6

ตัวอย่างการปรับ Code โดยใน Program ได้เพิ่ม Sheet1 เอาไว้รับข้อมูลและ Add Reference ชื่อ Microsoft ActiveX Data Objects 6.1 Library เข้ามาด้วย

Code นี้จะนำข้อมูลจากไฟล์และชีตต้นทางที่เข้าเงื่อนไขทุกบรรทัดมาแสดง หากต้องการจะตัดให้เหลือเท่าที่ต้องการสามารถเขียน Code สำหรับจัดการขึ้นมาต่างหากครับ

Code: Select all

Sub sample2()
    Dim FileSystem As Object
    Dim HostFolder As String

    HostFolder = "D:\Detail\wetransfer_2022-1-zip_2022-10-25_1306\"
    
    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder2 FileSystem.GetFolder(HostFolder)
End Sub

Sub DoFolder2(Folder)
    Dim SubFolder
    Dim File
    Dim n As Long
    Dim n2 As Long
    Dim sh As Worksheet
    Dim tws As Workbook
    For Each SubFolder In Folder.SubFolders
        DoFolder2 SubFolder
    Next
    For Each File In Folder.Files
        If Left(File.Name, 10) = "FINAL COST" Then
            n = Sheets("List").Range("A" & Rows.Count).End(xlUp).Row
            n2 = Sheets("Detail1").Range("C" & Rows.Count).End(xlUp).Row
            Sheets("List").Range("B" & n + 1) = Folder.Name
            Sheets("List").Range("A" & n + 1) = File.Name
            Call GetSheetname(theFullName:=File)
        End If
    Next
End Sub

Sub ImportFile(sFile As String, sh As String)
    Dim sCnstr As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim sql As String, shtName As String
    On Error Resume Next
    shtName = "[" & VBA.Replace(sh, "'", "") & "]"
    sql = "select * from " & shtName
    sCnstr.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
        & "Data Source=" & sFile & ";" _
        & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    rs.Open sql, sCnstr
    With Worksheets("Sheet1")
        .Range("A" & Rows.Count).End(xlUp).Offset(1, 0) _
            .CopyFromRecordset rs
    End With
    Set sCnstr = Nothing
    Set rs = Nothing
End Sub

Function GetSheetname(ByVal theFullName As String) As String
    Dim cn As ADODB.Connection
    Dim rsT As ADODB.Recordset
    Dim intTblCnt As Integer
    Dim strTbl As String
    Dim t As Integer
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
        & "Data Source=" & theFullName & ";" _
        & "Extended Properties=""Excel 12.0 Xml;HDR=NO"";"

    Set rsT = cn.OpenSchema(adSchemaTables)
    intTblCnt = rsT.RecordCount

    Do While Not rsT.EOF
        strTbl = rsT.Fields("TABLE_NAME").Value
        If Right(strTbl, 2) = "$'" And VBA.Left(strTbl, 11) = "'COST SHEET" Then
           Call ImportFile(sFile:=theFullName, sh:=strTbl)
        End If
        rsT.MoveNext
    Loop
    rsT.Close
    cn.Close
End Function

parakorn · #7

snasui wrote: Mon Oct 31, 2022 7:59 pm

ตัวอย่างการปรับ Code โดยใน Program ได้เพิ่ม Sheet1 เอาไว้รับข้อมูลและ Add Reference ชื่อ Microsoft ActiveX Data Objects 6.1 Library เข้ามาด้วย

Code นี้จะนำข้อมูลจากไฟล์และชีตต้นทางที่เข้าเงื่อนไขทุกบรรทัดมาแสดง หากต้องการจะตัดให้เหลือเท่าที่ต้องการสามารถเขียน Code สำหรับจัดการขึ้นมาต่างหากครับ

Code: Select all

Sub sample2()
    Dim FileSystem As Object
    Dim HostFolder As String

    HostFolder = "D:\Detail\wetransfer_2022-1-zip_2022-10-25_1306\"
    
    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder2 FileSystem.GetFolder(HostFolder)
End Sub

Sub DoFolder2(Folder)
    Dim SubFolder
    Dim File
    Dim n As Long
    Dim n2 As Long
    Dim sh As Worksheet
    Dim tws As Workbook
    For Each SubFolder In Folder.SubFolders
        DoFolder2 SubFolder
    Next
    For Each File In Folder.Files
        If Left(File.Name, 10) = "FINAL COST" Then
            n = Sheets("List").Range("A" & Rows.Count).End(xlUp).Row
            n2 = Sheets("Detail1").Range("C" & Rows.Count).End(xlUp).Row
            Sheets("List").Range("B" & n + 1) = Folder.Name
            Sheets("List").Range("A" & n + 1) = File.Name
            Call GetSheetname(theFullName:=File)
        End If
    Next
End Sub

Sub ImportFile(sFile As String, sh As String)
    Dim sCnstr As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim sql As String, shtName As String
    On Error Resume Next
    shtName = "[" & VBA.Replace(sh, "'", "") & "]"
    sql = "select * from " & shtName
    sCnstr.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
        & "Data Source=" & sFile & ";" _
        & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    rs.Open sql, sCnstr
    With Worksheets("Sheet1")
        .Range("A" & Rows.Count).End(xlUp).Offset(1, 0) _
            .CopyFromRecordset rs
    End With
    Set sCnstr = Nothing
    Set rs = Nothing
End Sub

Function GetSheetname(ByVal theFullName As String) As String
    Dim cn As ADODB.Connection
    Dim rsT As ADODB.Recordset
    Dim intTblCnt As Integer
    Dim strTbl As String
    Dim t As Integer
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" _
        & "Data Source=" & theFullName & ";" _
        & "Extended Properties=""Excel 12.0 Xml;HDR=NO"";"

    Set rsT = cn.OpenSchema(adSchemaTables)
    intTblCnt = rsT.RecordCount

    Do While Not rsT.EOF
        strTbl = rsT.Fields("TABLE_NAME").Value
        If Right(strTbl, 2) = "$'" And VBA.Left(strTbl, 11) = "'COST SHEET" Then
           Call ImportFile(sFile:=theFullName, sh:=strTbl)
        End If
        rsT.MoveNext
    Loop
    rsT.Close
    cn.Close
End Function

สุดยอดเลยครับอาจารย์ ขอกราบขอบพระคุณมากครับ

Snasui Excel Forum

File Anatomy Add-in: ตรวจสอบโครงสร้างไฟล์ Excel อย่างมืออาชีพ

Loop Sub Folder

Loop Sub Folder

Re: Loop Sub Folder

Re: Loop Sub Folder

Re: Loop Sub Folder

Re: Loop Sub Folder

Re: Loop Sub Folder

Re: Loop Sub Folder