如何提取文件夹下所有excel文档中的员工照片及姓名到新表

alai1222

请教各位老师，如何提取文件夹下所有excel文档中的员工姓名及照片到新表，位置固定。详见附件。谢谢。
           

alai1222

谢谢各位老师，看看有没有什么好办法，最好是能统一图片尺寸的

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, i&, strFileName$, strPath$, shp As Shape, dic As Object
   
    Application.ScreenUpdating = False
   
    For Each shp In ActiveSheet.Shapes
        If shp.Type = msoPicture Then shp.Delete
    Next
   
    Set dic = CreateObject("Scripting.Dictionary")
    With [A1].CurrentRegion
        ar = .Value
        For i = 2 To UBound(ar)
            Set dic(ar(i, 1)) = .Cells(i, 2)
        Next i
        
        strPath = ThisWorkbook.Path & "\"
        strFileName = Dir(strPath & "*.xls*")
        Do Until strFileName = ""
            If strFileName <> ThisWorkbook.Name Then
                With GetObject(strPath & strFileName)
                    For Each shp In .ActiveSheet.Shapes
                        If shp.Type = msoPicture Then
                            shp.Copy
                            If dic.exists(.ActiveSheet.[E3].Value) Then
                                With dic(.ActiveSheet.[E3].Value)
                                    .Select
                                    .Parent.Paste
                                    Selection.ShapeRange.LockAspectRatio = msoTrue
                                    Selection.Height = .RowHeight
                                End With
                            End If
                            Exit For
                        End If
                    Next
                    .Close False
                End With
            End If
            strFileName = Dir
        Loop
    End With
   
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考附件。。。

alai1222

gwjkkkkk 发表于 2024-5-8 21:10
请参考附件。。。

感谢帮助，谢谢