问与答87： 如何根据列表内容在文件夹中查找图片并复制到另一个文件夹中？

Sub CopyPic()
    '声明变量
    Dim strSourcePath As String
    Dim strDesPath As String
    Dim strFile As String
    Dim iCount As Long
    Dim strFilename() As String
    Dim lngLastRow As Long
    Dim i As Long
    Dim bln As Boolean
   
    '指定照片所在文件夹和要复制到的文件夹
    '示例假设工作簿与文件夹在同一目录下
   strSourcePath = ThisWorkbook.Path & "\照片库\"
    strDesPath= ThisWorkbook.Path & "\一班照片\"
 
    '获取文件
    strFile =Dir(strSourcePath)
   
    '获取工作表最后一行
    lngLastRow= Worksheets("Sheet1").Range("C" &Rows.Count).End(xlUp).Row
   
    '重定义动态数组
    ReDim strFilename(0 To iCount)
    If strFile<> "" Then
       strFilename(iCount) = strFile
    Else
        Exit Sub
    End If
   
    '遍历照片所在文件并将所有照片名称存储在数组中
    Do While strFile <> ""
        iCount= iCount + 1
        ReDim Preserve strFilename(0 To iCount)
        strFile= Dir
       strFilename(iCount) = strFile
    Loop
   
    '遍历工作表
    For i = 2 To lngLastRow
        bln = False
        '遍历数组
        For iCount = LBound(strFilename) To UBound(strFilename)
            '查找照片名称
            If Worksheets("Sheet1").Range("C" & i).Value =Left(strFilename(iCount), 18) Then
                '如果找到将其复制到目标文件夹
               FileCopy strSourcePath & strFilename(iCount), strDesPath &strFilename(iCount)
               bln = True
            End If
        Next iCount
        '根据照片是否找到填写列D相应单元格值
        If bln Then
           Worksheets("Sheet1").Range("D" & i).Value ="有"
        Else
           Worksheets("Sheet1").Range("D" & i).Value ="无"
        End If
    Next i
End Sub