Results 1 to 20 of 38

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

Threaded View

Previous Post Previous Post   Next Post Next Post
  1. #5
    Where would I place the 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
    Dim fso As Object, folder1 As Object
    ' 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) & "\"
    Call sMoveFiles(xRg, xSPathStr, xDPathStr)
    End Sub
    
    Sub sMoveFiles(xRg As Range, xSPathStr As Variant, xDPathStr As Variant)
    Dim xCell As Range
    Dim xVal As String
    Dim xFolder As Object
    Dim fso As Object
    Dim xF As Object
    Dim xStr As String
    Dim xFS As Object
    Dim xI As Integer
    On Error Resume Next
    If Dir(xDPathStr, vbDirectory) = "" Then
    MkDir (xDPathStr)
    End If
    For xI = 1 To xRg.Count
    Set xCell = xRg.Item(xI)
    xVal = xCell.Value
    If TypeName(xVal) = "String" And Not (xVal = "") Then
    On Error GoTo E1
    If Dir(xSPathStr & xVal, 16) <> Empty Then
    FileCopy xSPathStr & xVal, xDPathStr & xVal
    Kill xSPathStr & xVal
    End If
    End If
    E1:
    Next xI
    On Error Resume Next
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set xFS = fso.GetFolder(xSPathStr)
    For Each xF In xFS.SubFolders
    xStr = xDPathStr & "\" & xF.Name ' Replace(xF.ShortPath, xSPathStr, xDPathStr)
    Call sMoveFiles(xRg, xF.ShortPath & "\", xStr & "\")
    If (CreateObject("scripting.FileSystemObject").GetFolder(xStr).Files.Count = 0) _
    And (CreateObject("scripting.FileSystemObject").GetFolder(xStr).SubFolders.Count = 0) Then
    RmDir xStr
    End If
    Next
    End Sub
    Last edited by Paul_Hossler; 04-04-2020 at 02:33 PM.

Posting Permissions

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