VBA(10)导入图片,但是多文件夹例子

1.VBA导入产品图片分年份分季度文件夹例子应用

附图:测试模拟场景为箱包类每年的产品图片存放的文件夹为:年份-四季-产品编号

Sub jiatu1()                '多文件夹指定添加图片例子
    Dim shapes1 As Shape
    Dim x As Integer
    Dim y As Integer    '记数
    Dim z As Integer
    Dim v As Integer
    Dim rng As Range
    Dim mulu(1 To 4) As String
    For Each shapes1 In Worksheets(1).Shapes        '循环表格内的图片
        shapes1.Delete                              '删除图片
    Next
    Dim dir2 As String
    Dim str2 As String
    Dim str3 As String
    Dim str4 As String      '存放文本
    y = 1
    str2 = Dir("C:\Users\Administrator\Desktop\2022年份\" & "*", 16)        '本机上是放在桌面文件夹的2022年份测试,第二参数16代表所有文件跟文件夹
        Do While str2 <> ""
        If Not str2 Like "*.*" Then   '改成不带. 号，即是文件夹
            mulu(y) = str2              '将文件夹下的子文件夹名子装入数组mulu
            y = y + 1
        End If
        str2 = Dir                      '下一个文件
        Loop
    For z = 2 To Range("a65536").End(xlUp).Row      '从第二行开始处理
        For v = 1 To UBound(mulu)                   '目录里面循环
            str3 = ThisWorkbook.Path & "\" & mulu(v) & "\" & Cells(z, 1) & ".png"           '图片为PNG格式
             If Dir(str3, 16) <> Empty Then                     '如果文件存在则执行
             Worksheets(1).Pictures.Insert(str3).Select         '从cells（Z,1)选中
             Set rng = Cells(z, 2)                              '添加图片的单元格是
             With Selection                      '选中单元格与刚放置的图片
                    .Top = rng.Top + 1              '顶边距
                    .Left = rng.Left + 1            '左边距
                    .Width = rng.Width - 1              '宽度
                    .Height = rng.Height - 1            '高度
                End With                        '设置图片与音元格的尺才一致
             End If
        Next
    Next
    MsgBox "完成"
End Sub

例子思路是先遍历年份下的所有文件夹装入数组，再来按产品名匹配；

同理如果遇到其他类型分类也可一样处理；需注意例子图片导入方式默认了PNG格式，另根据OFFICE版本：有一些版本在判断文件是否存在：DIR(文件路径带名称)<>EMPTY此句子下会报错，需加上on error resume next

2.提取目录下所有文件包括子目录

根椐例子1，可以先定义一个数组1设定提取的初始目录将目录下所有文件夹提取出来，再定义数组2分别提取所有文件

Sub wenjian1()
    'On Error Resume Next
    Dim brr(1 To 1000) As String     '存所有文件夹名称及路径
    Dim f$, f2$
    Dim i, k#, x, q As Integer
    Dim arr(1 To 10000, 1 To 1) As String '存在查找到的所有文件
    
    '提取路径下所有文件夹装入数组
    brr(1) = ThisWorkbook.Path & "\"        '赋值一起起始文件目录位置
    Cells(1, 1) = brr(1)                    '输出到单元格
    i = 1: k = 1                            '初始化值
    Do While i <= k                          '循环条件是i小于等于文件夹的个数
        f = Dir(brr(i), vbDirectory)                    'f=遍历本文件夹下的
        Do While f <> ""
            If InStr(f, ".") = 0 And f <> "" Then       '如果F的名称存在点话而不为空的话
            k = k + 1                                   '记数+1
            brr(k) = brr(i) & f & "\"                   '把文件夹名装入数组下一个
            Cells(k, 1) = brr(k)                        '输出到A列
        End If
        f = Dir                                         '下一个
        Loop
        i = i + 1                                       '下一个文件夹
    Loop
    '提取各个文件夹的文件
    For x = 1 To UBound(brr)                            '循环数组
        If brr(x) = "" Then Exit For                    '如果数组为空则退出
         f2 = Dir(brr(x) & "*.*")                       '*.*=所有文件
        Do While f2 <> ""
            q = q + 1                                   '新数组记录数
            arr(q, 1) = brr(x) & f2                    '装入新数组
            f2 = Dir
        Loop
    Next x
    Range("b1").Resize(q) = arr                         '将结果输出到B列
    MsgBox "完成"
End Sub

定义的数组brr是装文件目录的个数

arr为装文件名的个数，定义为二维是方便转置输出.