以下vba代码报错下标越界请找出原因并输出修改后的代码。Option Explicit Sub FindAndCopyPictures On Error GoTo ErrorHandler 添加错误处理 Dim fso As New FileSystemObject Dim Folder As ScriptingFolder Dim subFolder

问题在于数组picPaths()在使用前没有初始化，需要在代码开头加上“ReDim picPaths(0)”进行初始化。

修改后的代码：

Option Explicit

Sub FindAndCopyPictures() On Error GoTo ErrorHandler '添加错误处理

Dim fso As New FileSystemObject
Dim Folder As Scripting.Folder
Dim subFolder As Scripting.Folder
Dim File As Scripting.File

Dim picPaths() As String '保存匹配成功的图片文件路径
ReDim picPaths(0)
Dim picIndex As Integer '匹配成功的图片文件数量

Dim dict As Object '字典对象，用于保存产品名称列表
Dim i As Integer
Dim Key As Object

'读取Excel中的产品名称列表，建立一个字典对象
Set dict = CreateObject("Scripting.Dictionary")
With ThisWorkbook.Sheets("Sheet1")
    For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
        dict(.Cells(i, 1).Value) = True
    Next i
End With

'遍历指定文件夹及其子文件夹下的所有图片文件
Set Folder = fso.GetFolder("C:\Users\wjm12\工作文档\#KUKA\材料+产品图片 - 重命名\外贸浏览图缩略图 - 重命名\0常用产品图片") '指定要查找的文件夹路径
picIndex = 0 '初始化匹配成功的图片文件数量
For Each subFolder In Folder.SubFolders
    For Each File In subFolder.Files
        '判断当前文件是否为图片文件
        If InStr(1, "|.jpg|.jpeg|.bmp|.gif|.png|", "|" & fso.GetExtensionName(File.Path) & "|", vbTextCompare) > 0 Then
            '对每个图片文件进行匹配
            For Each Key In dict.keys
                If InStr(1, File.Name, Key, vbTextCompare) > 0 Then
                    '判断当前文件是否已经存在于picPaths数组中
                    If Not IsInArray(File.Path, picPaths) Then
                        '将匹配成功的图片文件路径添加到数组中
                        ReDim Preserve picPaths(picIndex) '扩展数组
                        picPaths(picIndex) = File.Path
                        picIndex = picIndex + 1 '匹配成功的图片文件数量加1
                    End If
                    Exit For '跳出循环，避免重复添加同一张图片
                End If
            Next Key
        End If
    Next File
Next subFolder

'创建一个新的文件夹，将匹配成功的图片文件复制到该文件夹中
Dim newFolder As Object
Set newFolder = fso.CreateFolder("C:\Users\wjm12\Desktop\NewPictures") '指定新建的文件夹路径
For i = 0 To UBound(picPaths)
    fso.CopyFile picPaths(i), newFolder.Path & "\" & fso.GetFileName(picPaths(i)), True '添加重复文件处理
Next i

'释放对象
Set fso = Nothing
Set dict = Nothing

Exit Sub

ErrorHandler: MsgBox Err.Description, vbExclamation, "Error " & Err.Number '显示错误信息 Set fso = Nothing Set dict = Nothing End Sub

Function IsInArray(valToBeFound As Variant, arr As Variant) As Boolean '判断valToBeFound是否在arr数组中 Dim element As Variant On Error GoTo NotFound For Each element In arr If element = valToBeFound Then IsInArray = True Exit Function End If Next element NotFound: IsInArray = False End Functio