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（当然需要添加对＃34; Microsoft Scripting Runtime＆＃34; library：Tools-＆gt; References的引用，然后向下滚动列表框和选择＆＃34; Microsoft Scripting Runtime＆＃34;复选框）

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

1 个答案: