求大神帮忙，跟上次发布的类似，依据B列姓名，提取签名图

yjihau009

跟上次类似，依据B列姓名，提取签名图在AA列，有2个表（在职工资表和离职工资表）麻烦大神帮忙！！！

yynrzwh

工资表资料.zip (196.02 KB, 下载次数: 8)

2024-3-23 12:48 上传

点击文件名下载附件

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim Rng As Range, rngFind As Range, strFirstAddress$
    Dim strPath$, strFileName$, shp As Shape
   
    strPath = ThisWorkbook.Path & "\"
    For Each shp In ActiveSheet.Shapes
        If shp.Type = 11 Then shp.Delete
    Next
   
    Set Rng = Columns("B")
    Set rngFind = Rng.Find("*", , , xlWhole)
    If Not rngFind Is Nothing Then
        strFirstAddress = rngFind.Address
        Do
            strFileName = strPath & "\签名图\" & rngFind.Value & ".png"
            If Dir(strFileName) <> "" Then
                rngFind.Offset(, 25).Select
                ActiveSheet.Pictures.Insert(strFileName).Select
                With Selection
                    .Height = ActiveCell.Height
                    .Width = ActiveCell.Width
                End With
            End If
            Set rngFind = Rng.FindNext(rngFind)
        Loop Until rngFind.Address = strFirstAddress
    End If
    Set Rng = Nothing: Set rngFind = Nothing
End Sub

gwjkkkkk

请参考附件。。。