VBA 循环遍历每个单元格以复制文件

Question

我有一个 Excel 文件，其中列 (icol) 每个单元格都包含一些文件的路径，如下所示：

             column A                         column B          column c
P:\Desktop\Source\Test1-folder\file1.txt       empty column     P:\Desktop\Source\Test1-folder\filetest.txt            
P:\Desktop\Source\Test1-folder\file2.txt        .....

我需要遍历这些单元格以将单元格中的文件复制到目标文件夹中，但我无法成功。谁能帮忙怎么做？

Dim strSlash As String, destinationFolder As String
Dim lastcolumn As Long, icol As Long, lastLigne As Long
Dim rngCell As Range, rngFiles As Range
Dim FSO As New FileSystemObject
destinationFolder = "P:\Desktop\folderdestination"
Dim maListe As Object
Dim workboo As Workbook
Dim worksh As Worksheet

Set workboo = Workbooks.Open(P:\Desktop\Source\excelfile.xlsx)
Set worksh = workboo.Worksheets("path_files")

lastcolumn = Cells(1, Cells.Columns.Count).End(xlToLeft).Column
     If Dir(destinationFolder, 16) = "" Then MkDir (destinationFolder)
         For icol = 1 To lastcolumn Step 2
            lastLigne = Cells(Rows.Count, icol).End(xlUp).Row
            Set rngFiles = Cells(1, icol).Resize(lastLigne)
                 For Each rngCell In rngFiles.Cells
                 If Dir(rngCell.Value) <> "" Then 
                 strFile = Right(rngCell.Value, Len(rngCell.Value) - InStrRev(rngCell.Value, "\"))
                 If Dir(destinationFolder & "\" & Left(strFile, 5) , 16) = "" Then
                  FSO.CopyFile rngCell.Value, destinationFolder & "\" & Left(strFile, 5)           
                   End If
                 End If
                  Next rngCell
          Next icol

结束子

Answer 1

已编辑以添加对源文件存在的检查

应该这样做

Option Explicit

Sub main()

    Dim strSlash As String, destinationFolder As String
    Dim lastcolumn As Long, icol As Long, lastLigne As Long
    Dim rngCell As Range, rngFiles As Range
    Dim FSO As New FileSystemObject

    strSlash = "\"
    destinationFolder = "P:\Desktop\folderdestination"
    lastcolumn = Cells(1, Cells.Columns.Count).End(xlToLeft).Column
    For icol = 1 To lastcolumn Step 2
        lastLigne = Cells(Rows.Count, icol).End(xlUp).Row
        Set rngFiles = Cells(1, icol).Resize(lastLigne)
        For Each rngCell In rngFiles.Cells
            If Dir(rngCell.Value) <> "" Then '<~~ check if the source file is actually there!
                If Dir(destinationFolder & "\" & Right(rngCell.Value, Len(rngCell.Value) - InStrRev(rngCell.Value, strSlash)), 16) = "" Then
                    FSO.CopyFile rngCell.Value, destinationFolder & "\" & Right(rngCell.Value, Len(rngCell.Value) - InStrRev(rngCell.Value, strSlash))
                End If
            End If
        Next rngCell
    Next icol

End Sub

但它仍然可以在很大程度上改进，更彻底地利用 FileSystemObject（这当然需要添加对“Microsoft Scripting Runtime”库的引用：Tools->References 然后向下滚动列表框并选择“Microsoft Scripting Runtime”复选框）