循环子目录 [英] Loop Through Sub-Dir

问题描述

Sub CheckandSend()Dim strfile 作为字符串Dim ws As Worksheet '确保定义一个工作表设置 ws = ThisWorkbook.Worksheets(RFQ")工作表(零件清单").选择表格(RFQ").选择昏暗的 lastrow 一样长lastrow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row范围(A6:E"& lastrow).选择Application.CutCopyMode = False选择.复制工作表(零件清单").选择单元格选择Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _:=假，转置:=假Application.CutCopyMode = False单元格选择Cells.EntireColumn.AutoFitDim Worksheet2_Name As StringWorkRFQ_Name = "零件清单";' 将其替换为您要导出的第一个工作表的名称设置 WorkRFQ = ThisWorkbook.Worksheets(WorkRFQ_Name)Dim Write_Directory As StringDim WorkRFQ_Path 作为字符串Write_Directory = P:CENTRAL PLANNINGPROJECTS 2020-2021VAM-TARSONNewfolder1"WorkRFQ_Path = Write_Directory &"&WorkRFQ_NameWorkRFQ.ExportAsFixedFormat _类型:=xlTypePDF, _文件名:=WorkRFQ_Path, _质量:=xlQualityStandard，_IncludeDocProperties:=True, _忽略打印​​区域:=假，_OpenAfterPublish:=False工作表(零件清单").选择列(A:Z").选择选择.删除表格(RFQ").选择Dim SourcePath As StringSourcePath = I:MechanicalExternalProjectsCummins Emission Systems35101124 PT Cup Test Rig16 PDF to Vendor";Dim DestPath 作为字符串DestPath = P:CENTRAL PLANNINGPROJECTS 2020-2021VAM-TARSONNewfolder1"昏暗一样长Dim f As SearchFoldersDim 文件类型为字符串文件类型 =*.pdf"艾罗 = 7Do While ws.Cells(irow, 2) <>空字符串将文件名变暗为字符串FileName = Dir(SourcePath & ws.Cells(irow, 2) & "*.pdf")执行 While FileName <>空字符串VBA.FileCopy SourcePath &文件名、目标路径和文件名文件名 = 目录()环形irow = irow + 1环形结束子

在这里，此代码可帮助我找到源路径中存在的 pdf 文件 &插入那个文件 &放在我的目的地现在我落后的地方是，在我的源路径(pdf 到供应商)中，在这个文件夹之后有多个子文件夹，我想要一个代码来循环遍历所有子文件夹并找到我的文件并将其放在我的目标路径中

我的子文件夹看起来像 OP10、OP20、OP30.....ETC...,

解决方案

这是一个函数，该函数将返回一组匹配的 file 对象给定起始位置和文件名模式:

'返回给定起始文件夹和文件模式的文件对象集合'例如*.txt"'如果不想检查子文件夹，则为最后一个参数传递 False函数 FileMatches(startFolder As String, filePattern As String, _可选的子文件夹 As Boolean = True) As Collection昏暗的 fso、fldr、f、subFldr将 colFiles 调暗为新集合 '<<所有匹配的文件将 colSub 调暗为新集合 '<<要扫描匹配文件的文件夹Set fso = CreateObject("scripting.filesystemobject")colSub.Add startFolder '<<添加起始文件夹'当仍有文件夹需要扫描时循环做 While colSub.Count >0设置 fldr = fso.getfolder(colSub(1))colSub.Remove 1 '<<从列表中删除我们现在正在扫描的文件夹For Each f In fldr.Files '获取文件夹中的文件'如果文件名与模式相似，则添加到hits"中收藏If UCase(f.Name) Like UCase(filePattern) Then colFiles.Add f下一个If subFolders Then '获取子文件夹进行处理?对于 fldr.subFolders 中的每个 subFldrcolSub.Add subFldr.Path '<<将子文件夹添加到列表进行处理下一个子文件夹万一环形Set FileMatches = colFiles '返回所有匹配的文件结束函数

基于您发布的代码的示例用法:

Dim SourcePath As String, DestPath As StringDim colFiles as Collection, fSourcePath = I:MechanicalExternalProjectsCummins Emission Systems35101124 PT Cup Test Rig16 PDF to Vendor";DestPath = P:CENTRAL PLANNINGPROJECTS 2020-2021VAM-TARSONNewfolder1"昏暗一样长Dim f As SearchFoldersDim 文件类型为字符串文件类型 =*.pdf"艾罗 = 7Do While ws.Cells(irow, 2) <>空字符串设置 colFiles = FileMatches(SourcePath, ws.Cells(irow, 2) & "*.pdf")对于 colFiles 中的每个 ff.复制目标路径&f.姓名下一个irow = irow + 1环形

Sub CheckandSend()
    Dim strfile As String
    Dim ws As Worksheet 'make sure to define a sheet
    Set ws = ThisWorkbook.Worksheets("RFQ")
    Sheets("Part list").Select
    Sheets("RFQ").Select
    Dim lastrow As Long
    lastrow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
    Range("A6:E" & lastrow).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Part list").Select
    Cells.Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Cells.Select
    Cells.EntireColumn.AutoFit
Dim Worksheet2_Name As String
WorkRFQ_Name = "Part list" ' Replace this with the name of the first sheet you want to export
Set WorkRFQ = ThisWorkbook.Worksheets(WorkRFQ_Name)
Dim Write_Directory As String
Dim WorkRFQ_Path As String
Write_Directory = "P:CENTRAL PLANNINGPROJECTS 2020-2021VAM-TARSONNewfolder1" 
WorkRFQ_Path = Write_Directory & "" & WorkRFQ_Name
WorkRFQ.ExportAsFixedFormat _
    Type:=xlTypePDF, _
    FileName:=WorkRFQ_Path, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False
    
    Sheets("Part list").Select
    Columns("A:Z").Select
    Selection.Delete
    Sheets("RFQ").Select
    Dim SourcePath As String
    SourcePath = "I:MechanicalExternalProjectsCummins Emission Systems35101124 PT Cup Test Rig16 PDF to Vendor"
    Dim DestPath As String
    DestPath = "P:CENTRAL PLANNINGPROJECTS 2020-2021VAM-TARSONNewfolder1"

    Dim irow As Long
    Dim f As SearchFolders
    Dim filetype As String
    filetype = "*.pdf"
    irow = 7
    
    Do While ws.Cells(irow, 2) <> vbNullString
        Dim FileName As String
        FileName = Dir(SourcePath & ws.Cells(irow, 2) & "*.pdf")
       
        Do While FileName <> vbNullString
            VBA.FileCopy SourcePath & FileName, DestPath & FileName
            FileName = Dir()
        Loop
        
        irow = irow + 1
    Loop
end sub

On here, this code is help me to find an pdf file which is present in my sourcepath & plug that file & place in my destpath now where i am lagging is, in my sourcepath (pdf to vendor") after this folder there are multiple sub-folders , i want a code which loop through all sub-folders and find my files and place it in my dest path

my sub folders will be look like OP10, OP20, OP30.....ETC...,

解决方案

Here's a function which will return a collection of matching file objects given a starting location and a file name pattern:

'Return a collection of file objects given a starting folder and a file pattern
'  e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function FileMatches(startFolder As String, filePattern As String, _
                    Optional subFolders As Boolean = True) As Collection

    Dim fso, fldr, f, subFldr
    Dim colFiles As New Collection  '<< all matched files
    Dim colSub As New Collection    '<< folders to be scanned for matching files
    
    Set fso = CreateObject("scripting.filesystemobject")
    colSub.Add startFolder   '<< add the starting folder
    
    'loop while there are still folders to be scanned
    Do While colSub.Count > 0
        Set fldr = fso.getfolder(colSub(1))
        colSub.Remove 1   '<< remove the folder we're now scanning from the list
        For Each f In fldr.Files 'get files in folder
            'if the filename is like the pattern, add to the "hits" collection
            If UCase(f.Name) Like UCase(filePattern) Then colFiles.Add f
        Next f
        If subFolders Then 'get subfolders for processing?
            For Each subFldr In fldr.subFolders
                colSub.Add subFldr.Path  '<< add subfolder to list for processing
            Next subFldr
        End If
    Loop
    Set FileMatches = colFiles 'return all matched files
End Function

Example usage based on your posted code:

    Dim SourcePath As String, DestPath As String
    Dim colFiles as Collection, f

    SourcePath = "I:MechanicalExternalProjectsCummins Emission Systems35101124 PT Cup Test Rig16 PDF to Vendor"
    
    DestPath = "P:CENTRAL PLANNINGPROJECTS 2020-2021VAM-TARSONNewfolder1"

    Dim irow As Long
    Dim f As SearchFolders
    Dim filetype As String
    filetype = "*.pdf"
    irow = 7
    
    Do While ws.Cells(irow, 2) <> vbNullString
        
        Set colFiles = FileMatches(SourcePath, ws.Cells(irow, 2) & "*.pdf")
        For Each f in colFiles
            f.Copy DestPath & f.Name
        Next f
        
        irow = irow + 1
    Loop

这篇关于循环子目录的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！