Results 1 to 4 of 4

Thread: Advice with VBA Code to Move Files
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    Board Regular
    Join Date
    Aug 2005
    Posts
    544
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Advice with VBA Code to Move Files

    Hi there,

    I wondering if there is somebody out there who can help me with a macro to move files.

    I have a Excel list of files which have the full path and filename in column A, which has been obtain from a Windows search.

    What I am trying to do is move these files form there various folder locations to a single location which I wish to define.

    I have search and cannot seem to find a macro which does this.

    I found the code below but it assumes that the files to be moved reside in all the same folder.

    Can it be amended to work as required?

    I know a little VBA but this is a bit over my head

    thanks in advance for any help

    Regards

    Desmond

    Code:
    Sub movefiles()
    'Updateby Extendoffice
        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:", "KuTools For Excel", 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
                Kill xSPathStr & xVal
            End If
        Next
    End Sub

  2. #2
    MrExcel MVP
    Moderator
    Fluff's Avatar
    Join Date
    Jun 2014
    Location
    Chippenham
    Posts
    27,958
    Post Thanks / Like
    Mentioned
    467 Post(s)
    Tagged
    47 Thread(s)

    Default Re: Advice with VBA Code to Move Files

    How about
    Code:
    Sub purceld2()
       Dim Fso As Object
       Dim Cl As Range
       Dim Fldr As String
       
       Set Fso = CreateObject("scripting.filesystemobject")
       With Application.FileDialog(4)
          .AllowMultiSelect = False
          If .Show = -1 Then Fldr = .SelectedItems(1)
       End With
       
       For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
          Fso.movefile Cl.Value, Fldr & "\"
       Next Cl
    End Sub
    - Posting Data try one of these tools
    - Posting guidelines, forum rules and terms of use
    - Read the FAQs

    Running Office 365 on Win 10

  3. #3
    Board Regular
    Join Date
    Aug 2005
    Posts
    544
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Advice with VBA Code to Move Files

    Hi Fluff,

    Thanks for your prompt reply very much appreciated.

    The macro works fine just one issue I wonder if I could ask if you could help. Sometimes the Windows search includes Folders names in the results which unfortunately causes the macro to stop.

    Would it be possible to get the macro to ignore anything it cannot move and produce a audit trail please.

    Thanks again for your help


    Regards
    Desmond
    Last edited by Fluff; Sep 21st, 2019 at 12:44 PM.

  4. #4
    MrExcel MVP
    Moderator
    Fluff's Avatar
    Join Date
    Jun 2014
    Location
    Chippenham
    Posts
    27,958
    Post Thanks / Like
    Mentioned
    467 Post(s)
    Tagged
    47 Thread(s)

    Default Re: Advice with VBA Code to Move Files

    How about
    Code:
    Sub purceld2()
       Dim Fso As Object
       Dim Cl As Range
       Dim Fldr As String
       
       Set Fso = CreateObject("scripting.filesystemobject")
       With Application.FileDialog(4)
          .AllowMultiSelect = False
          If .Show = -1 Then Fldr = .SelectedItems(1)
       End With
       
       For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
          If Fso.FileExists(Cl.Value) Then
          Fso.movefile Cl.Value, Fldr & "\"
          End If
       Next Cl
    End Sub
    - Posting Data try one of these tools
    - Posting guidelines, forum rules and terms of use
    - Read the FAQs

    Running Office 365 on Win 10

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
  •