Results 1 to 4 of 4

Thread: VBA search subfolder and move to another folder

  1. #1
    New Member
    Join Date
    Sep 2019
    Posts
    2
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default VBA search subfolder and move to another folder

    Hi All,

    Long time lurker but first time poster. I have a scenario where I'd like to use a list in Excel to search for and copy the corresponding files to another folder. I believe I have most of the code written and it seems to work fine except for two small issues. One issue is that I need to be able to search the subfolders. Right now, it only searches the main folder identified and not the many subfolders beneath. The other issue is that it needs to search for partial matches. Right now, it only searches for exact matches including file extension. I would like it to move the file if it contains the words from the list. Below is the current code I have. Any help would be much appreciated. Thank you!

    Sub copyfiles()
    'Updateby JHey
    Dim xRg As Range, xCell As Range
    Dim xSFileDlg As FileDialog, xDFileDlg As FileDialog
    Dim xSPathStr As Variant, xDPathStr As Variant
    Dim xVal As String
    On Error Resume Next
    Set xRg = Application.InputBox("Please select the file names:", "JHey", ActiveWindow.RangeSelection.Address, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    xSFileDlg.Title = "Please select the original folder:"
    If xSFileDlg.Show <> -1 Then Exit Sub
    xSPathStr = xSFileDlg.SelectedItems.Item(1) & ""
    Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    xDFileDlg.Title = "Please select the destination folder:"
    If xDFileDlg.Show <> -1 Then Exit Sub
    xDPathStr = xDFileDlg.SelectedItems.Item(1) & ""
    For Each xCell In xRg
    xVal = xCell.Value
    If TypeName(xVal) = "String" And xVal <> "" Then
    FileCopy xSPathStr & xVal, xDPathStr & xVal
    End If
    Next
    End Sub

  2. #2
    Board Regular
    Join Date
    Mar 2016
    Posts
    222
    Post Thanks / Like
    Mentioned
    2 Post(s)
    Tagged
    2 Thread(s)

    Default Re: VBA search subfolder and move to another folder

    Welcome to the forum.

    Let's start with this and see how close it gets you. The code finds the first file to match the xVal text and moves that to the destination folder. Then, it moves on to the next xVal. If you need it to find all occurences, then we'll need to change the code. I've put the code in blue to indicate what's different in your original Sub routine. Obviously, all text outside of your original routine is new.

    I borrowed some code for the recursion of the folders from HERE.

    This code uses early binding, so you need to set a reference to Microsoft Scripting Runtime in the VB Editor:
    1) click Tools, References
    2) search the list (alphabetical order) until you find Microsoft Scripting Runtime
    3) check the box and click OK

    Code:
    Dim blNotFirstIteration As BooleanDim Fil As File
    Dim hFolder As Folder, SubFolder As Folder
    Dim NameOfFile As String
    Dim FSO As Scripting.FileSystemObject
    
    Sub copyfiles()
    'Updateby JHey
        Dim xRg As Range, xCell As Range
        Dim xSFileDlg As FileDialog, xDFileDlg As FileDialog
        Dim xSPathStr As Variant, xDPathStr As Variant
        Dim xVal As String
        On Error Resume Next
        Set xRg = Application.InputBox("Please select the file names:", "JHey", ActiveWindow.RangeSelection.Address, , , , , 8)
        If xRg Is Nothing Then Exit Sub
        Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
        xSFileDlg.Title = "Please select the original folder:"
        If xSFileDlg.Show <> -1 Then Exit Sub
        xSPathStr = xSFileDlg.SelectedItems.Item(1) & ""
        Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
        xDFileDlg.Title = "Please select the destination folder:"
        If xDFileDlg.Show <> -1 Then Exit Sub
        xDPathStr = xDFileDlg.SelectedItems.Item(1) & ""
        For Each xCell In xRg
            blNotFirstIteration = False
            NameOfFile = ""
            xVal = xCell.Value
            If TypeName(xVal) = "String" And xVal <> "" Then
                FindFilesInFolders xSPathStr, xVal
                If NameOfFile <> "" Then
                    FileCopy Fil.Path, xDPathStr & "\" & NameOfFile
                End If
            End If
        Next
    End Sub
    
    Sub FindFilesInFolders(ByVal HostFolder As String, FileName As String)
        If NameOfFile <> "" Then Exit Sub
    
        If FSO Is Nothing Then Set FSO = New Scripting.FileSystemObject
        Set hFolder = FSO.GetFolder(HostFolder)
    
        ' iterate through all files in the root of the main folder
        If Not blNotFirstIteration Then
          For Each Fil In hFolder.Files
              If InStr(1, FSO.GetFileName(Fil.Path), FileName) > 0 Then
                  NameOfFile = FSO.GetFileName(Fil.Path)
                  Exit Sub
              End If
          Next Fil
        
          ' make recursive call, if main folder contains subfolder
          If Not hFolder.SubFolders Is Nothing Then
              blNotFirstIteration = True
              Call FindFilesInFolders(HostFolder, FileName)
              If NameOfFile <> "" Then Exit Sub
          End If
        
        ' iterate through all files in all the subfolders of the main folder
        Else
          For Each SubFolder In hFolder.SubFolders
                For Each Fil In SubFolder.Files
                    If InStr(1, FSO.GetFileName(Fil.Path), FileName) > 0 Then
                         NameOfFile = FSO.GetFileName(Fil.Path)
                         Exit Sub
                     End If
              Next Fil
        
              ' make recursive call, if subfolder contains subfolders
              If Not SubFolder.SubFolders Is Nothing Then
                  Call FindFilesInFolders(HostFolder & "\" & SubFolder.Name, FileName)
                  If NameOfFile <> "" Then Exit Sub
              End If
          Next SubFolder
        End If
        blNotFirstIteration = False
    End Sub
    Last edited by shknbk2; Sep 20th, 2019 at 01:04 AM.
    Hobby: VBA and some .Net
    Career: the world of patent and trademark protection

    - forum use guidelines, forum rules and terms of use
    - Try searching for your answer first, see how
    - Read the FAQs
    - List of BB codes

  3. #3
    New Member
    Join Date
    Sep 2019
    Posts
    2
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA search subfolder and move to another folder

    That worked flawlessly! Thank you so much for your help!!

  4. #4
    Board Regular
    Join Date
    Mar 2016
    Posts
    222
    Post Thanks / Like
    Mentioned
    2 Post(s)
    Tagged
    2 Thread(s)

    Default Re: VBA search subfolder and move to another folder

    You're welcome.
    Hobby: VBA and some .Net
    Career: the world of patent and trademark protection

    - forum use guidelines, forum rules and terms of use
    - Try searching for your answer first, see how
    - Read the FAQs
    - List of BB codes

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •