时间戳

首页 > 解决方案 > 将工作簿一一复制到存档文件夹

vba - 将工作簿一一复制到存档文件夹

问题描述

我使用了下面的代码，它完美地完成了拾取所有文件并将它们移动到存档文件夹的工作。但是，我正在寻找要逐个提取的文件，将日期放入目标工作簿并将其移动到存档文件夹，此过程一直持续到最后一个工作簿。我使用下面的代码来复制数据并调用 Sub 例程来执行存档。但它会在第一次迭代中将所有文件一次移动到存档文件夹中。

Sub Test()
    Dim xWb As Workbook
    Dim xToBook As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    Dim xFiles As New Collection
    Dim I As Long
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder [Kutools for Excel]"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
    xFile = Dir(xStrPath & "*.xlsx")
    If xFile = "" Then
        MsgBox "No files found", vbInformation, "Kutools for Excel"
        Exit Sub
    End If
    Do While xFile <> ""
        xFiles.Add xFile, xFile
        xFile = Dir()
    Loop
    Set xToBook = ThisWorkbook
    If xFiles.Count > 0 Then
        For I = 1 To xFiles.Count
            Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
            xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)
            On Error Resume Next
            ActiveSheet.Name = xWb.Name
            On Error GoTo 0
            xWb.Close False
            '**Call MoveFiles_3**
        Next I
    End If
End Sub

Sub MoveFiles_3()
    Dim fso As Object, d As String, ext, x
    Dim srcPath As String, destPath As String, srcFile As String
    srcPath = "C:\Users\userfolder\Desktop\Test Macro\"
    destPath = "C:\Users\userfolder\Desktop\Archive Test\"
    Set fso = CreateObject("Scripting.FileSystemObject")
    ext = Array("*.xlsx")
    MsgBox Dir(srcPath)
    For Each x In ext
        d = Dir(srcPath & x)
        Do While d <> ""
            srcFile = srcPath & d
            fso.CopyFile srcFile, destPath & d
            Kill srcFile
        d = Dir
        Loop
    Next x
    MsgBox "done"
End Sub

标签： vbaexcel

解决方案

试试下面的代码。Test我在你的里面加了两行，没MoveFiles_3必要。

Sub Test()
    Dim xWb As Workbook
    Dim xToBook As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    Dim xFiles As New Collection
    Dim I As Long
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder [Kutools for Excel]"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
    xFile = Dir(xStrPath & "*.xlsx")
    If xFile = "" Then
        MsgBox "No files found", vbInformation, "Kutools for Excel"
        Exit Sub
    End If
    Do While xFile <> ""
        xFiles.Add xFile, xFile
        xFile = Dir()
    Loop
    Set xToBook = ThisWorkbook
    If xFiles.Count > 0 Then
        For I = 1 To xFiles.Count
            Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
            xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)
            On Error Resume Next
            ActiveSheet.Name = xWb.Name
            On Error GoTo 0
            xWb.Close False

            Name xStrPath & xFiles.Item(I) As "C:\Users\userfolder\Desktop\Archive Test\" & xFiles.Item(I) ' new added'
            Kill xStrPath & xFiles.Item(I) ' new added'
        Next I
    End If
End Sub

推荐阅读