Search code examples
arraysvbawscript.shellfilecopy

vba wscript.shell copy file from folder to another folder based on cell path or filename

I want to do it with vba wscript.shell because copying files is faster and I want to copy files based on path or filename in excel cell based on the selection in column "E" and output the destination folder using "msoFileDialogFolderPicker"

I have sample code but need to change.



Sub copy()
xDFileDlg As FileDialog
xDPathStr As Variant
sn = Filter(Split(CreateObject("wscript.shell").exec("cmd /c dir C:\copy\*.* /b /s").stdout.readall, vbCrLf), "\")
'For j = 0 To UBound(sn)
'If DateDiff("d", FileDateTime(sn(j)), Date) > 30 Then sn(j) = ""
'Next

sn = Filter(sn, "\")

For j = 0 To UBound(sn)
FileCopy sn(j), "C:\destcopy" & Mid(sn(j), 2)
Next
 Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
 xDFileDlg.Title = "Please select the destination folder:"
 If xDFileDlg.Show <> -1 Then Exit Sub
 xDPathStr = xDFileDlg.SelectedItems.Item(1) & "\"
End Sub

excel Thanks

roy

Solution

  • Please, test the next code. It assumes that you need to select the destination folder for copying of all files there. Otherwise, some milliseconds saved by VBScript object mean too little against the necessary seconds to browse for each file destination folder to be copied. But, if this is what you want, I can easily adapt the code to do that:

    Sub copyFiles()
  Dim sh As Worksheet, lastR As Long, arrA, i As Long, k As Long
  Dim fileD As FileDialog, strDestFold As String, FSO As Object
  
  Set sh = ActiveSheet
  lastR = sh.Range("A" & sh.rows.count).End(xlUp).row ' last row on A:A column
  arrA = sh.Range("A2:E" & lastR).Value2                   'place the range in an array for faster iteration
  Set FSO = CreateObject("Scripting.FileSystemObject")
  With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please select the destination folder!"
        .AllowMultiSelect = False
        If .Show = -1 Then
            strDestFold = .SelectedItems.Item(1) & "\"   'select the destination folder
        End If
  End With
  If strDestFold = "" Then Exit Sub                         'in case of  not selecting any folder
  For i = 1 To UBound(arrA)
     If UCase(arrA(i, 5)) = "V" Then                         'copy the file only if a "V" exists in column E:E
        If FSO.FileExists(arrA(i, 1)) Then                    'check if the path in excel is correct
            FSO.CopyFile arrA(i, 1), strDestFold, True     'copy the file (True, to overwrite the file if it exists)
            k = k + 1
        Else
            MsgBox arrA(i, 1) & " file could not be found." & vbCrLf & _
                        "Please, check the spelling and correct the file full path!", vbInformation, _
                        "File does not exist..."
        End If
     End If
  Next i
  MsgBox "Copied " & k & " files in " & strDestFold, , "Ready..."
End Sub