VBA 如何快速批量插入多张图片

cycycy97

经常需要通过商品代码匹配商品图片，但是现在用的VBA对多张图片的插入太久了（差不多要8-10分钟）。有没有大佬能优化下我的vba，或者给个新的。感激不尽。

cycycy97

附上现在正在用的VBA。
Sub 当前单元插入图片()
On Error Resume Next
Dim dress$
    Set dig = Application.FileDialog(msoFileDialogFolderPicker)
   With dig
         .Show
  dress = .SelectedItems(1)                 '选择文件夹地址
       End With
Dim MR As Range
For Each MR In Selection
  If Not IsEmpty(MR) Then
    MR.Select
    ML = MR.Left
    MT = MR.Top
    MW = MR.Width
    MH = MR.Height
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, ML, MT, MW, MH).Select
    Selection.ShapeRange.Fill.UserPicture _
       dress & "\" & MR.Value & ".jpg"     '设置地址所在目录下以当前单元内容为名称的.jpg图片
   End If
Next
End Sub

cycycy97

目前一次插入1000张照片，差不多要8-10分钟。

朱科技

可以使用VBA中的FileSystemObject对象和Excel中的函数来实现商品代码和商品图片的匹配。具体步骤如下1. 在Excel中创建一个表格，其中一列是商品代码，另一列是商品图片的文件名2. 使用FileSystemObject对象读取图片文件夹中所有的图片文件名，并将这些文件名保存到一个数组中3. 使用For循环遍历商品代码列中的每个商品代码，在数组中查找是否有与之对应的图片文件名。如果存在，则使用Excel中的HYPERLINK函数将该图片文件名与商品代码关联起来，以便在Excel中单击该链接时显示商品图片代码示例``Sub MatchImage    Dim f As Object    Dim filePath As String    Dim fileNames() As String    Dim code As String    Dim i As Long    '图片文件夹路径    filePath = \C:\\Images\\    '使用FileSystemObject对象读取文件夹中所有的文件名    Set f = CreateObject(\Scripting.FileSystemObject    ReDim fileNames(f.GetFolder(filePath).Files.Count - 1    i = 0    For Each file In f.GetFolder(filePath).Files        fileNames(i) = file.Name        i = i + 1    Next    '遍历商品代码列中的每个商品代码，查找对应的图片文件名    For Each cell In Range(\A2:A\ & Range(\A1\End(xlDown).Row        code = cell.Value        '在数组中查找与商品代码对应的图片文件名        i = Application.Match(code, fileNames, 0        If Not IsError(i) Then            '对应的图片文件名存在，设置该单元格的链接            cell.Offset(0, 1).Value = \HYPERLINK(\ & filePath & fileNames(i - 1) & \\\ & code & \\        End If    NextEnd Sub

cycycy97

附上我的vba。
Sub 当前单元插入图片()
On Error Resume Next
Dim dress$
    Set dig = Application.FileDialog(msoFileDialogFolderPicker)
   With dig
         .Show
  dress = .SelectedItems(1)                 '选择文件夹地址
       End With
Dim MR As Range
For Each MR In Selection
  If Not IsEmpty(MR) Then
    MR.Select
    ML = MR.Left
    MT = MR.Top
    MW = MR.Width
    MH = MR.Height
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, ML, MT, MW, MH).Select
    Selection.ShapeRange.Fill.UserPicture _
       dress & "\" & MR.Value & ".jpg"     '设置地址所在目录下以当前单元内容为名称的.jpg图片
   End If
Next
End Sub

3190496160

调试代码更是应该要上传相应的附件才行呀

liulang0808

cycycy97 发表于 2023-5-30 16:51
附上现在正在用的VBA。
Sub 当前单元插入图片()
On Error Resume Next

把屏幕刷新属性设置先设置为false，最后再设置为true，看看效果怎样吧

z865593849

我是从数据库取图片的，500张可以秒取，中间代码可以参考

山海风云轩

做个记号，学习学习   

perfect131

用 Selection ，如果电脑配置不高 当然会慢
arr=Selection.value
arr=[a2:a1000]
用数组 ，行高尽量要统一 ，避免反复获取 Left，Top，Width，Height
如果还那么慢，上传附件