时间戳

首页 > 解决方案 > 如何从 Excel 中的列表中查找值并将这些文件复制到另一个目录？

excel - 如何从 Excel 中的列表中查找值并将这些文件复制到另一个目录？

问题描述

我想查看 A 列中的值列表，然后查找该值 + 该文件夹中存在的扩展名 + .jpeg 扩展名，然后将这些照片复制到特定文件夹中。

我的代码只适用于第一个目录，不能从其他两个目录复制。
代码也很慢（可能是因为照片大小？）。
我还需要使其动态化，以便它查找 A 列中的所有值，而不仅仅是 A1:A4。

Private Function CountFiles()
strDirectory1 = "N:\Decostar\Algemeen\Website\005_SFEER"
strDirectory2 = "N:\Decostar\Algemeen\Website\006_SFEER"
strDirectory3 = "N:\Decostar\Algemeen\Website\007_SFEER"
strDestFolder = "N:\Decostar\AA Verkoop binnendienst\Z Hidde\Tes"
strExt = "xls"
 Dim myfilesystemobject As Object
 Dim myfiles As Object
 Dim myfile As Object
 Dim rng As Range
 
 Set rng = ThisWorkbook.ActiveSheet.Range("A1:A4") 'set this to the range of your filtered list
 Set myfilesystemobject = CreateObject("Scripting.FileSystemObject")
 Set myfiles = myfilesystemobject.GetFolder(strDirectory1).Files
 For Each cell In rng
 For Each myfile In myfiles
 If Not IsNull(cell.Value) Then
 If myfile = strDirectory1 & "\" & cell.Value & "_5.jpg" Then

 With myfile
 .Copy strDestFolder & "\" & myfile.Name
 End With
 Else
 End If
  If myfile = strDirectory2 & "\" & cell.Value & "_6.jpg" Then

 With myfile
 .Copy strDestFolder & "\" & myfile.Name
 End With
 Else
 End If
 If myfile = strDirectory3 & "\" & cell.Value & "_7.jpg" Then

 With myfile
 .Copy strDestFolder & "\" & myfile.Name
 End With
 Else
 End If
 End If
 Next myfile
 Next cell
End Function

标签： excelvba

解决方案

您可以使用 FileSystemObject FileExists方法来避免扫描目录中的所有文件。

Sub macro()

    Dim strDirectory(3) As String
    strDirectory(1) = "N:\Decostar\Algemeen\Website\005_SFEER"
    strDirectory(2) = "N:\Decostar\Algemeen\Website\006_SFEER"
    strDirectory(3) = "N:\Decostar\Algemeen\Website\007_SFEER"
      
    Const strDestFolder = "N:\Decostar\AA Verkoop binnendienst\Z Hidde\Tes"
  
    Dim ws As Worksheet
    Dim myFSO, myfile As String, myname As String
    Dim rng As Range, cell As Range
    Dim i As Integer, n As Long, iLastRow As Long
    
    Set myFSO = CreateObject("Scripting.FileSystemObject")
     
    Set ws = ThisWorkbook.ActiveSheet
    iLastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    Set rng = ws.Range("A2:A" & iLastRow).SpecialCells(xlCellTypeVisible)
    
    ' list of files to copy
    For Each cell In rng
        ' check file in each directory
        For i = 1 To 3
            myname = cell.Value & "_" & i + 4 & ".jpg"
            myfile = strDirectory(i) & "\" & myname
            If myFSO.FileExists(myfile) Then
                myFSO.CopyFile myfile, strDestFolder & "\" & myname
                n = n + 1
                'Debug.Print n, myfile, strDestFolder & "\" & myname
            End If
        Next
    Next
    MsgBox n & " files copied", vbInformation
End Sub

推荐阅读