vba wscript.shell 根据单元格路径或文件名将文件从文件夹复制到另一个文件夹

Question

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"

我有示例代码，但需要更改。

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

谢谢

罗伊

Answer 1

请测试下一个代码。 它假定您需要 select 目标文件夹以复制那里的所有文件。 否则，VBScript object 节省的几毫秒意味着浏览每个要复制的目标文件夹所需的秒数太少。 但是，如果这是您想要的，我可以轻松地修改代码来做到这一点：

Sub copyFiles()
  Dim sh As Worksheet, lastR As Long, arrA, i As Long, j 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:A" & 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 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)
        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..."
            j = j + 1
        End If
  Next i
  MsgBox "Copied " & UBound(arrA) - j & " files in " & strDestFold, , "Ready..."
End Sub