snasui.com ยินดีต้อนรับ ยินดีต้อนรับสู่กระดานถามตอบ Excel and VBA และอื่น ๆ ที่เป็นมิตรกับทุกท่าน มีไฟล์แนบมหาศาล ช่วยให้ท่านค้นหาและติดตามศึกษาได้โดยง่าย สมาชิกท่านใดที่ยังไม่ได้ระบุ Version ของ Excel ที่ใช้งานจริง สามารถทำตาม Link นี้เพื่อจะได้รับคำตอบที่ตรงกับ Version ของท่านครับ ระบุ Version ของ Excel
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
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
You do not have the required permissions to view the files attached to this post.
'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
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
You do not have the required permissions to view the files attached to this post.
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
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.com ยินดีต้อนรับ 
สมาชิกท่านใดที่ยังไม่ได้ระบุ Version ของ Excel ที่ใช้งานจริง สามารถทำตาม Link นี้เพื่อจะได้รับคำตอบที่ตรงกับ Version ของท่านครับ 
โปรดทราบ 
