[已解决]新人求助

alpha0

怎么用VBA在excle中批量插入图片，而且对于前后相同名字的单元格，只需要插入一张图片。

最佳答案

月排行榜 / 总排行榜

dsmch

2014-10-12 19:10

………………

跳转到最佳答案楼层

alpha0

C:\Users\Administrator\Desktop
要求是这样的，谢谢各位大神了

爱疯

Sub test()
    Dim A, i%, r%, p$, f$, s$
   
    Application.ScreenUpdating = False
    With ActiveSheet
        .Pictures.Delete
        r = .Range("b65536").End(xlUp).Row
        A = .Range("b2:b" & r)
        p = ThisWorkbook.Path & "\"
        'p = "C:\Users\Administrator\Desktop\"
        For i = 1 To r - 1
            f = A(i, 1)
            If Not s Like "*" & f & "*" Then
                .Cells(i + 1, 1).Select
                .Pictures.Insert p & f & ".jpg"
                s = s & f & ","
            End If
        Next
    End With
   
End Sub

dsmch

1. Sub Macro1()
   
2. Dim i&, s&, m As Shape
   
3. s = 2
   
4. For Each m In ActiveSheet.Shapes
   
5.     If m.Type <> 8 Then m.Delete
   
6. Next
   
7. For i = 3 To Range("b65536").End(xlUp).Row + 1
   
8.     If Cells(i, 2) <> Cells(i - 1, 2) Then
   
9.         Set rng = Range(Cells(s, 1), Cells(i - 1, 1))
   
10.         l = rng.Left: t = rng.Top
    
11.         w = rng.Width: h = rng.Height
    
12.         ActiveSheet.Shapes.AddShape(msoShapeRectangle, l, t, w, h).Select
    
13.         Selection.ShapeRange.Line.Visible = msoFalse
    
14.         Selection.ShapeRange.Fill.UserPicture ThisWorkbook.Path & "" & Cells(i - 1, 2) & ".jpg"
    
15.         s = i
    
16.     End If
    
17. Next
    
18. [a1].Activate
    
19. End Sub

复制代码

dsmch

………………

alpha0

dsmch 发表于 2014-10-12 19:10
………………

谢谢你了，帮我大忙了！