Consulting

Results 1 to 3 of 3

Thread: Change destination folder

  1. #1
    VBAX Regular
    Joined
    Feb 2018
    Posts
    70
    Location

    Change destination folder

    Hi, this macro is used to group files in a folder. It created a sub folder in the main folder but I now need it to create the folder in a different location. I've tried doing this myself but having difficulty. Can someone please point me in the correct direction?

    Thank you

    Sub FindFilesAndMove()    
    Dim MyFolder As String, MyFile As String, srchStr As String, DestFold As String, FSO As Object, rCell As Range
    
        Set FSO = CreateObject("Scripting.Filesystemobject")
        MyFolder = "Y:\accounts\Conv slips" '<<< change to suit
        For Each rCell In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Cells
           MyFile = Dir(MyFolder)
           srchStr = rCell.Value
           DestFold = MyFolder & srchStr & ""
           MkDir DestFold
           Do While MyFile <> ""
               If InStr(MyFile, srchStr) Then
                   FSO.MoveFile Source:=MyFolder & MyFile, Destination:=DestFold & MyFile
               End If
               MyFile = Dir
           Loop
       Next rCell
    End Sub
    Last edited by Bob Phillips; 01-21-2022 at 05:43 AM. Reason: Corrected code tags

  2. #2
    Moderator VBAX Master georgiboy's Avatar
    Joined
    Mar 2008
    Location
    Kent, England
    Posts
    1,158
    Location
    Hi Lee,

    When posting VBA use the # symbol (Wrap [CODE] tags around selected text), it makes it easier to read.

    See below for updated code with editable destination folder:

    Sub FindFilesAndMove()    
        Dim MyFolder As String, MyFile As String, srchStr As String, DestFoldFull As String, FSO As Object, rCell As Range
        Dim DestFold As String
        
        Set FSO = CreateObject("Scripting.Filesystemobject")
        MyFolder = "C:\Users\jbloggs\Desktop\test\" '<<< change to suit
        DestFold = "C:\Users\jbloggs\Desktop\" '<<< change to suit
        
        For Each rCell In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Cells
            MyFile = Dir(MyFolder)
            srchStr = rCell.Value
            DestFoldFull = DestFold & srchStr & "\"
            MkDir DestFoldFull
            Do While MyFile <> ""
                If InStr(MyFile, srchStr) Then
                    FSO.MoveFile Source:=MyFolder & MyFile, Destination:=DestFoldFull & MyFile
                End If
            MyFile = Dir
            Loop
        Next rCell
    End Sub
    Click here for a guide on how to add code tags
    Click here for a guide on how to mark a thread as solved

    Excel 365, Version 2401, Build 17231.20084

  3. #3
    VBAX Regular
    Joined
    Feb 2018
    Posts
    70
    Location
    Thanks again mate.

Posting Permissions

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