表格中引用文件夹中图片

sw706sw706

如附件中的需求，输入编号对应单元格，自动插入同目录下图片文件夹中的同名图片。折腾了一上午基本上达到了想实现的效果，但不能使用重复代码和图片，请大家帮忙解决下，谢谢！
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim a As Long
    a = Target.Row
   
    Dim Rng As Range, S As String
    On Error Resume Next
   
   Dim p As Shape
   Set My = Worksheets(1)
   For Each p In My.Shapes
   If Not Application.Intersect(p.TopLeftCell, Range("a" & a)) Is Nothing Then p.Delete
   Next
   
   
    S = Trim(Range("b" & a)) '档案号单元格
    Set Rng = Range("a" & a) '照片单元格
    Path = ThisWorkbook.Path & "\图片\"           '图片路径
   
    With ActiveSheet.Shapes(S)   '移动到指定位置
        .Left = Rng.Left + 10
        .Top = Rng.Top + 5
    End With
    If Err Then  '如果出错 说明没有添加图片，执行添加
        ActiveSheet.Shapes.AddPicture(Path & S & ".JPG", 1, 1, Rng.Left + 10, Rng.Top + 5, 90, 120).Name = S
        Err.Clear
    End If
End Sub

代号栏有重复显现的单元格，如在B4单元格用了111代号调用了111图片，B6单元格也可以用111代号调用111图片。（目前就这个问题没有解决了，表格不能有重复的代号和图片。望高手帮忙看下谢谢！）

wangg913

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Dim Picfile$
   
3.     Picfile = VBA.Dir(ThisWorkbook.Path & "\图片" & Target & ".*")
   
4.     If Target.Column = 2 And Picfile <> "" Then
   
5.         Dim PicPlace As Range, PicName$
   
6.         On Error Resume Next
   
7.         Set PicPlace = Target.Offset(, -1).Resize(2)
   
8.         Picfile = ThisWorkbook.Path & "\图片" & Picfile        '图片路径
   
9.         PicName = Target & -Target.Row
   
10.         
    
11.         With Sheet1.Shapes(PicName)   '移动到指定位置
    
12.             .Left = PicPlace.Left + 2
    
13.             .Top = PicPlace.Top + 2
    
14.             .Width = PicPlace.Width - 4
    
15.             .Height = PicPlace.Height - 4
    
16.         End With
    
17.    
    
18.         If Err Then  '如果出错 说明没有添加图片，执行添加
    
19.             Sheet1.Shapes.AddPicture(Picfile, msoTrue, msoture, _
    
20.                 PicPlace.Left + 2, PicPlace.Top + 2, PicPlace.Width - 4, PicPlace.Height - 4).Name = PicName
    
21.             Err.Clear
    
22.         End If
    
23.     End If
    
24. End Sub

复制代码

zzkof

wangg913 发表于 2015-7-31 23:33

如果是按输入代码显示图片，不移动的呢

dailei1992

也有这样的需求，希望能有大神解决这个问题