Consulting

Page 2 of 2 FirstFirst 1 2
Results 21 to 38 of 38

Thread: Help on Moving file to another folder, using partial filename

  1. #21
    Quote Originally Posted by Dave View Post
    So the file that U wanted transferred from the source folder ends up in the destination folder as U wanted? Do you want to remove the original file? The file has moved so I don't understand "need to add the move code" Dave
    Yes, remove the original file,

  2. #22
    VBAX Expert Dave's Avatar
    Joined
    Mar 2005
    Posts
    832
    Location
    This should do it...
    Sub sMoveFiles(xRg As Range, xSPathStr As Variant, xDPathStr As Variant)
    Dim fso As Object, xF As Object, xFS As Object, TempSplit As Variant
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set xFS = fso.GetFolder(xSPathStr)
    For Each xF In xFS.Files
    TempSplit = Split(xF.Name, "_")
    If TempSplit(0) = CStr(xRg) Then
    fso.CopyFile xSPathStr & xF.Name, xDPathStr & xF.Name, True
    Kill xSPathStr & xF.Name
    End If
    Next xF
    Set xFS = Nothing
    Set fso = Nothing
    End Sub

  3. #23
    Quote Originally Posted by Dave View Post
    This should do it...
    Sub sMoveFiles(xRg As Range, xSPathStr As Variant, xDPathStr As Variant)
    Dim fso As Object, xF As Object, xFS As Object, TempSplit As Variant
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set xFS = fso.GetFolder(xSPathStr)
    For Each xF In xFS.Files
    TempSplit = Split(xF.Name, "_")
    If TempSplit(0) = CStr(xRg) Then
    fso.CopyFile xSPathStr & xF.Name, xDPathStr & xF.Name, True
    Kill xSPathStr & xF.Name
    End If
    Next xF
    Set xFS = Nothing
    Set fso = Nothing
    End Sub
    When I select more than 1 cell I get an error "mismatch". That's only when I click on more that one filename in the cell. Anyway around that? Thanks

  4. #24
    VBAX Expert Dave's Avatar
    Joined
    Mar 2005
    Posts
    832
    Location
    Do U want to move more than 1 file at a time or just avoid this? Dave

  5. #25
    Quote Originally Posted by Dave View Post
    Do U want to move more than 1 file at a time or just avoid this? Dave
    Move more than 1 file at a time.

  6. #26
    VBAX Expert Dave's Avatar
    Joined
    Mar 2005
    Posts
    832
    Location
    That changes things a bit. Trial this. Dave
    Option Explicit
    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
    Dim fso As Object, folder1 As Object, TempRange As Range
    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 TempRange In xRg
    If Not sMoveFiles(TempRange.Text, xSPathStr, xDPathStr) Then
    MsgBox TempRange.Text & " :FILE DOESN'T EXIST!"
    End If
    Next TempRange
    End Sub
    Function sMoveFiles(xRg As String, xSPathStr As Variant, xDPathStr As Variant) As Boolean
    Dim fso As Object, xF As Object, xFS As Object, TempSplit As Variant
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set xFS = fso.GetFolder(xSPathStr)
    For Each xF In xFS.Files
    TempSplit = Split(xF.Name, "_")
    If TempSplit(0) = CStr(xRg) Then
    'copy source file to destination folder, overwrite file true/false
    fso.CopyFile xSPathStr & xF.Name, xDPathStr & xF.Name, True
    'remove original file
    'Kill xSPathStr & xF.Name
    fso.deletefile (xSPathStr & xF.Name), False
    sMoveFiles = True
    End If
    Next xF
    Set xFS = Nothing
    Set fso = Nothing
    End Function

  7. #27
    Quote Originally Posted by Dave View Post
    That changes things a bit. Trial this. Dave
    Option Explicit
    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
    Dim fso As Object, folder1 As Object, TempRange As Range
    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 TempRange In xRg
    If Not sMoveFiles(TempRange.Text, xSPathStr, xDPathStr) Then
    MsgBox TempRange.Text & " :FILE DOESN'T EXIST!"
    End If
    Next TempRange
    End Sub
    Function sMoveFiles(xRg As String, xSPathStr As Variant, xDPathStr As Variant) As Boolean
    Dim fso As Object, xF As Object, xFS As Object, TempSplit As Variant
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set xFS = fso.GetFolder(xSPathStr)
    For Each xF In xFS.Files
    TempSplit = Split(xF.Name, "_")
    If TempSplit(0) = CStr(xRg) Then
    'copy source file to destination folder, overwrite file true/false
    fso.CopyFile xSPathStr & xF.Name, xDPathStr & xF.Name, True
    'remove original file
    'Kill xSPathStr & xF.Name
    fso.deletefile (xSPathStr & xF.Name), False
    sMoveFiles = True
    End If
    Next xF
    Set xFS = Nothing
    Set fso = Nothing
    End Function
    The Macro works, but its hours glasses if I try to move a lot of files. Is there a code that I can add for the macro could handle moving large population of files? Thanks

  8. #28
    VBAX Expert Dave's Avatar
    Joined
    Mar 2005
    Posts
    832
    Location
    More new info which I hadn't considered. This should speed things up somewhat. Dave
    Function sMoveFiles(xRg As String, xSPathStr As Variant, xDPathStr As Variant) As Boolean
    Dim fso As Object, xF As Object, xFS As Object, TempSplit As Variant
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set xFS = fso.GetFolder(xSPathStr)
    For Each xF In xFS.Files
    TempSplit = Split(xF.Name, "_")
    If TempSplit(0) = CStr(xRg) Then
    'copy source file to destination folder, overwrite file true/false
    fso.CopyFile xSPathStr & xF.Name, xDPathStr & xF.Name, True
    'remove original file
    Kill xSPathStr & xF.Name
    'fso.deletefile (xSPathStr & xF.Name), False
    sMoveFiles = True
    Exit Function
    End If
    Next xF
    Set xFS = Nothing
    Set fso = Nothing
    End Function

  9. #29
    VBAX Expert Dave's Avatar
    Joined
    Mar 2005
    Posts
    832
    Location
    Maybe trial using movefile to see if it's any quicker as well...
    Function sMoveFiles(xRg As String, xSPathStr As Variant, xDPathStr As Variant) As Boolean
    Dim fso As Object, xF As Object, xFS As Object, TempSplit As Variant
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set xFS = fso.GetFolder(xSPathStr)
    For Each xF In xFS.Files
    TempSplit = Split(xF.Name, "_")
    If TempSplit(0) = CStr(xRg) Then
    'copy source file to destination folder, overwrite file true/false
    fso.moveFile xSPathStr & xF.Name, xDPathStr & xF.Name ', True
    'remove original file
    'Kill xSPathStr & xF.Name
    'fso.deletefile (xSPathStr & xF.Name), False
    sMoveFiles = True
    Exit Function
    End If
    Next xF
    Set xFS = Nothing
    Set fso = Nothing
    End Function
    Dave

  10. #30
    Quote Originally Posted by Dave View Post
    Maybe trial using movefile to see if it's any quicker as well...
    Function sMoveFiles(xRg As String, xSPathStr As Variant, xDPathStr As Variant) As Boolean
    Dim fso As Object, xF As Object, xFS As Object, TempSplit As Variant
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set xFS = fso.GetFolder(xSPathStr)
    For Each xF In xFS.Files
    TempSplit = Split(xF.Name, "_")
    If TempSplit(0) = CStr(xRg) Then
    'copy source file to destination folder, overwrite file true/false
    fso.moveFile xSPathStr & xF.Name, xDPathStr & xF.Name ', True
    'remove original file
    'Kill xSPathStr & xF.Name
    'fso.deletefile (xSPathStr & xF.Name), False
    sMoveFiles = True
    Exit Function
    End If
    Next xF
    Set xFS = Nothing
    Set fso = Nothing
    End Function
    Dave
    I'll give it a try this evening. Thanks

  11. #31
    Quote Originally Posted by Xtremedesign View Post
    I'll give it a try this evening. Thanks
    Working great, is there a way to capture the error "when the filename is not found " and past it into a cell?

  12. #32
    VBAX Expert Dave's Avatar
    Joined
    Mar 2005
    Posts
    832
    Location
    Which code is working great? The file copy would be better... if U use move file then U have to first check to make sure the file doesn't already exist in the destination folder. Copyfile as coded replaces any existing file (ie. easier). Paste "the file not found" where? Dave

  13. #33
    Quote Originally Posted by Dave View Post
    Which code is working great? The file copy would be better... if U use move file then U have to first check to make sure the file doesn't already exist in the destination folder. Copyfile as coded replaces any existing file (ie. easier). Paste "the file not found" where? Dave
    The file is moving all the excel sheet correctly, would be nice if the error that say "file not found" the Filename not found could go next to the filename in a different cell. Easier to keep track of what filename was not moved.

  14. #34
    VBAX Expert Dave's Avatar
    Joined
    Mar 2005
    Posts
    832
    Location
    I guess were going to go with copyfile then. Give this a trial. Dave
    Option Explicit
    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
    Dim fso As Object, folder1 As Object, TempRange As Range
    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 TempRange In xRg
    If Not sMoveFiles(TempRange.Text, xSPathStr, xDPathStr) Then
    'MsgBox TempRange.Text & " :FILE DOESN'T EXIST!"
    TempRange.Offset(0, 1) = "FILE DOESN'T EXIST!"
    End If
    Next TempRange
    End Sub
    Function sMoveFiles(xRg As String, xSPathStr As Variant, xDPathStr As Variant) As Boolean
    Dim fso As Object, xF As Object, xFS As Object, TempSplit As Variant
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set xFS = fso.GetFolder(xSPathStr)
    For Each xF In xFS.Files
    TempSplit = Split(xF.Name, "_")
    If TempSplit(0) = CStr(xRg) Then
    'copy source file to destination folder, overwrite file true/false
    fso.CopyFile xSPathStr & xF.Name, xDPathStr & xF.Name, True
    'remove original file
    Kill xSPathStr & xF.Name
    sMoveFiles = True
    GoTo Below
    End If
    Next xF
    Below:
    Set xFS = Nothing
    Set fso = Nothing
    End Function

  15. #35
    Quote Originally Posted by Dave View Post
    I guess were going to go with copyfile then. Give this a trial. Dave
    Option Explicit
    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
    Dim fso As Object, folder1 As Object, TempRange As Range
    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 TempRange In xRg
    If Not sMoveFiles(TempRange.Text, xSPathStr, xDPathStr) Then
    'MsgBox TempRange.Text & " :FILE DOESN'T EXIST!"
    TempRange.Offset(0, 1) = "FILE DOESN'T EXIST!"
    End If
    Next TempRange
    End Sub
    Function sMoveFiles(xRg As String, xSPathStr As Variant, xDPathStr As Variant) As Boolean
    Dim fso As Object, xF As Object, xFS As Object, TempSplit As Variant
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set xFS = fso.GetFolder(xSPathStr)
    For Each xF In xFS.Files
    TempSplit = Split(xF.Name, "_")
    If TempSplit(0) = CStr(xRg) Then
    'copy source file to destination folder, overwrite file true/false
    fso.CopyFile xSPathStr & xF.Name, xDPathStr & xF.Name, True
    'remove original file
    Kill xSPathStr & xF.Name
    sMoveFiles = True
    GoTo Below
    End If
    Next xF
    Below:
    Set xFS = Nothing
    Set fso = Nothing
    End Function
    This worked Perfectly. Thanks, I will donate to this site.

  16. #36
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    Did you guys ever hear of indentation ????


    Sub M_start()
       M_snb "G:\OF\From\", "G:\OF\To\","abc"
    End Sub
    Sub M_snb(c00, c01, c02)
      c03= dir(c00 & c02 & "_*")
      
      do while c03<>""
        name  c00 & c03 As c01 & c03
        c03=Dir
      loop
    End Sub

  17. #37
    VBAX Expert Dave's Avatar
    Joined
    Mar 2005
    Posts
    832
    Location
    You are welcome Extremedesign and thanks for posting your outcome. snb I agree it would be nice to indent and fully comment all code. Your code certainly offers a simple solution to copying files to new locations but would require some adjustments to achieve the full outcome. I also hate using DIR after having some frustrating experience with the DIR function not finding files even though they clearly existed... so now I stick to the filesystem object. Anyways, as always, thanks for your input. Stay safe. Dave

  18. #38
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    Dave,

    The code I posted doesn't copy, but moves files.
    I never had any problems with 'Dir'.

Posting Permissions

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