关于自动插入图片的问题

美人计 · 发表于 2009-7-2 17:29

在另一个版块看到关于自动插入图片的问题探讨,很激动
因为我日常工作中用到的频率很高,每次都只能安排助理一个货号一个货号的贴图,速度奇慢.
可是,在那边版快放了好多天也没人理会,所以把链接贴过来,希望有高手能帮忙解决,不胜感激
http://club.excelhome.net/viewth ... &extra=page%3D1

yuanzhuping · 发表于 2009-7-2 18:03

Sub InsertPic()
Dim iRow As Single, Shp As Shape, Target As Range, FilPath As String
With ActiveSheet
For iRow = 4 To .Cells(65536, 1).End(xlUp).Row
FilPath = ThisWorkbook.Path & "" & .Cells(iRow, 2) & ".jpg"
If Dir(FilPath) <> "" Then
.Pictures.Insert(FilPath).Select
Set Target = .Cells(iRow, 3)
With Selection
.Top = Target.Top + 1
.Left = Target.Left + 1
.Width = Target.Width - 1
.Height = Target.Height - 1
End With
End If
Next
End With
End Sub

复制代码

来生缘 · 发表于 2009-7-2 18:12

仅供参考。。

美人计 · 发表于 2009-7-2 20:05

谢谢楼上的两位老师
问个外行的问题:图片来源如果改变的话，应该把以上的VBA语言改动哪里呢?

PS:我对VBA和宏一窍不通

风之助 · 发表于 2009-7-2 20:07

将红色部分改为你自己的文件夹名称:
FilPath = ThisWorkbook.Path & "\" & .Cells(iRow, 2) & ".jpg"

[ 本帖最后由风之助于 2009-7-2 20:09 编辑 ]

美人计 · 发表于 2009-7-3 09:57

对不起大家,还是没搞懂

依葫芦画瓢了，还是不行
我把源文件发上来,哪位大侠帮我看看哪里错了好不好?我的品图片是存在F盘目录下的命名为"服装图片"的文件夹里,图片后缀名全部为".BMP".

因为平时用到这个功能的频率确实太高,所以只能先请大家帮忙,用上再说.
最近我在学透视表和函数,有点基础后会努力学VBA.
谢谢大家

[ 本帖最后由美人计于 2009-7-3 17:22 编辑 ]

yuanzhuping · 发表于 2009-7-3 11:19

Sub 简洁()
Dim iRow As Single, Shp As Shape, Target As Range, FilPath As String
With ActiveSheet
For iRow = 2 To .Cells(65536, 1).End(xlUp).Row
FilPath = "F:\服装图片" & .Cells(iRow, 4) & ".bmp"
If Dir(FilPath) <> "" Then
.Pictures.Insert(FilPath).Select
Set Target = .Cells(iRow, 5)
With Selection
.Top = Target.Top + 1
.Left = Target.Left + 1
.Width = Target.Width - 1
.Height = Target.Height - 1
End With
End If
Next
End With
End Sub

复制代码

美人计 · 发表于 2009-7-3 16:09

可能是我太笨了，宏还是运行不了
我已经把图片的附件一起上传了,在6楼,大家帮我看看好吗?
我的图片名称是跟"6月30日报表"里的货号一样的,即以货号来选择相对应的图片,
图片名称有的没有"A"开头,是不是会有影响?可是我把名称都改成跟货号一样了，还是运行不了.
另外,是不是"6月30日报表"里面货号不在第一列也有关系?

来生缘 · 发表于 2009-7-3 16:32

改了你的图片命名，因为图片的命名在表里没有。

美人计 · 发表于 2009-7-3 17:26

换了个工作表,楼上的代码又不行了,见附件
弄了一个下午，也试了YUANZHUPING老师的VBA代码解析,也没成功

我在想，除了图片路径,其他的应该不需要更改什么吧?实在不明白

代码如下:
Sub inserpic()
Application.ScreenUpdating = False
Dim iRow As Single, Shp As Shape, Target As Range, FilPath As String, sh As Object
ActiveSheet.Shapes.SelectAll
On Error GoTo 1
For Each sh In Selection
      If Left(sh.Name, 3) = "Pic" Then sh.Delete
Next
1:

With ActiveSheet
      For iRow = 2 To .Cells(65536, 1).End(xlUp).Row
         FilPath = ThisWorkbook.Path & "\图片\" & .Cells(iRow, 4) & ".bmp"
         If Dir(FilPath) <> "" Then
            .Pictures.Insert(FilPath).Select
            Set Target = .Cells(iRow, 5)
            With Selection
                  .Top = Target.Top + 1
                  .Left = Target.Left + 1
                  .Width = Target.Width - 1
                  .Height = Target.Height - 1
            End With
         End If
      Next
End With
Application.ScreenUpdating = True

End Sub

		自动登录	找回密码
密码			免费注册

[求助] 关于自动插入图片的问题