Question

每天，我将多个文件从指定位置复制到目标文件夹。

进入每个文件夹，选择文件并粘贴到目标文件夹是一项繁琐的任务。

注意：完整文件名每天更改。我想使用一部分文件名。

例如-对于ABC_REPOOO15_DDMMYYY，我想使用REP00015，因为这将是恒定的。

A1                 B1                                   C1
File name        Source folder                      Destination folder
REP00015     C:\Users\Sam's Lps\Desktop\Soucre      C:\Users\Sam's Lps\Desktop\Destination

我尝试了以下代码

Sub movefiles()

    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

    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 xCell In xRg
        xVal = xCell.Value
        If TypeName(xVal) = "String" And xVal <> "" Then
            FileCopy xSPathStr & xVal, xDPathStr & xVal
            Kill xSPathStr & xVal
        End If
    Next

End Sub

Answer 1

在将所有文件名都复制到一个excel数据表中后，附加的代码将立即起作用。是你的情况吗？如果是的话，那是可行的。

如果不是这种情况，请在目标目录上创建一个已启用的Excel文件宏，然后添加此宏：

Sub MoveFiles()

Dim xRg As Range, xCell As Range
Dim xSFileDlg As FileDialog, xDFileDlg As FileDialog
Dim xSPathStr As Variant, xDPathStr As Variant
Dim xVal,MyPath, MyFileName, Aux As String
Dim x

x = Shell("cmd /k dir ABC_REPOOO15*.* /b >list.txt", vbHide)

MyPath = ActiveWorkbook.Path
MyFileName = "list.txt"
Aux = "TEXT;" & MyPath & "/" & MyFileName

    With ActiveSheet.QueryTables.Add(Connection:=Aux _
        , Destination:=Range("$A$1"))
        .Name = "list"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 850
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With

On Error Resume Next

Set xRg = Application.InputBox("Please select the file names:", , 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 xCell In xRg
    xVal = xCell.Value
    If TypeName(xVal) = "String" And xVal <> "" Then
        FileCopy xSPathStr & xVal, xDPathStr & xVal
        Kill xSPathStr & xVal
    End If
Next

End Sub

该宏将在excel数据表中创建文件列表。您可以选择文件，目标目录和最终目录并完成。

无论如何，您可以为其他一些文件定制此宏。

“ dir * .TMP / b> list.txt”

要获取目录中的所有* .TMP文件。

希望有帮助。

将多个文件从不同的文件夹复制到不同的目标文件夹

1 个答案: