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

Question

我想用 vba wscript.shell 来做，因为复制文件更快，我想根据“E”列中的选择在 excel 单元格中根据路径或文件名复制文件，并使用“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

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

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