我想查看 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
答案 0 :(得分:0)
您可以使用 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