遍历工作表，把符合要求的图片导入到指定单元格

WZD28

打开采购计划表，点击“导入图片”按钮，遍历文件夹各部门表格。
1、如果“采购计划表”C列“物品编号”和文件夹内各部门表格的“物品编号”一致的话，把相同物品编号的图片导入到“采购计划表”“备注/图片”单元格。
2、如果“采购计划表”物品没有“物品编号”，可以核对各部门表格的物品名称，如果一致的话，把相同物品名称图片导入到“采购计划表”“备注/图片”单元格。
有些一个物品有几张图片，要求也导入到“备注/图片”单元格，图片不压缩像素，谢谢！

    汇总表 01.rar (397.24 KB, 下载次数: 15)

2024-4-26 15:50 上传

点击文件名下载附件

WZD28

烦请各位大师能否帮忙解决，谢谢！

liulang0808

Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    Set fso = CreateObject("scripting.filesystemobject")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set sh = ThisWorkbook.Sheets(1)
    arr = sh.UsedRange
    For j = 4 To UBound(arr)
        If Len(arr(j, 3)) > 0 Then
            Set d(arr(j, 3)) = Cells(j, "v")
        Else
            If Len(arr(j, 4)) > 0 Then
                Set d(arr(j, 4)) = Cells(j, "v")
            End If
        End If
    Next j
    For Each f In fso.GetFolder(ThisWorkbook.Path).Files
        If InStr(f.Name, ThisWorkbook.Name) + InStr(f.Name, "$") = 0 Then
            With Workbooks.Open(f)
                arr = .Sheets(1).UsedRange
                Set rng = .Sheets(1).Rows(2).Find("图片", lookat:=xlWhole)
                If rng Is Nothing Then
                    Set rng = .Sheets(1).Rows(2).Find("备注／用途", lookat:=xlWhole)
                    If rng Is Nothing Then GoTo l1
                End If
                m = rng.Column
                For j = 3 To UBound(arr)
                    If Len(arr(j, 3)) > 0 Then
                        If d.Exists(arr(j, 3)) Then
                            .Sheets(1).Cells(j, m).Copy d(arr(j, 3))
                        Else
                            If d.Exists(arr(j, 4)) Then
                                .Sheets(1).Cells(j, m).Copy d(arr(j, 4))
                            End If
                        End If
                    End If
                Next j
l1:
                .Close False
            End With
        End If
    Next f
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

liulang0808

文件中的图片列不固定，不确定在哪个位置的，做了简单的对应，供参考

WZD28

liulang0808 发表于 2024-5-5 12:22
文件中的图片列不固定，不确定在哪个位置的，做了简单的对应，供参考

谢谢版主 ！！ 是我想要的结果，但在运行是发现没有物品编号的物品图片不能导入。
物品没有“物品编号”，可以查询各部门表格的物品名称及规格型号，如果一致的话，把相同物品名称图片导入到“采购计划表”“备注/图片”单元格


   

liulang0808

WZD28 发表于 2024-5-5 14:41
谢谢版主 ！！ 是我想要的结果，但在运行是发现没有物品编号的物品图片不能导入。
物品没有“物品编号” ...

代码中先判断的是否有编号，有编号的话就不会管名称
如果没有编号，就会根据名称取匹配的

WZD28

liulang0808 发表于 2024-5-5 15:30
代码中先判断的是否有编号，有编号的话就不会管名称
如果没有编号，就会根据名称取匹配的

经检查物品名称都是相同的，还是不能导入图片。

liulang0808

.....................