求助大神，Excel可以自动插入数据和照片

yvonne900801

如附件，现有N条数据需要填写到表格中，还需要在表格中插入人员照片

安若浅笑

查找图片的表格要有一份对照表

gwjkkkkk

数据源也没有，照片也没有，怎么写？生成的是一人一表还是在一个表格中生成，还是一人一个工作簿？

yvonne900801

gwjkkkkk 发表于 2024-1-23 20:51
数据源也没有，照片也没有，怎么写？生成的是一人一表还是在一个表格中生成，还是一人一个工作簿？

不好意思，已将附件更新，数据源在表格的第二个工作表，照片在单独的文件夹中，生成的表格最好是一人一个独立的文件。感谢感谢

橒♂蝣

邮件合并比较好用

gwjkkkkk

Option Explicit
Sub test0()
    Dim ar, br, cr, i&, j&, f, strFileName$, strPath$, wks As Worksheet, strExtName$, dic As Object
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
   
    Set dic = CreateObject("Scripting.Dictionary")
    strPath = ThisWorkbook.Path & "\照片\"
    With CreateObject("VBScript.RegExp")
        .Pattern = "jpg|jpep|png|gif|bmp|gif"
        .IgnoreCase = True
        For Each f In CreateObject("Scripting.FileSystemObject").GetFolder(strPath).Files
            strExtName = Mid(f.Name, InStrRev(f.Name, ".") + 1)
            strFileName = Left(f.Name, InStrRev(f.Name, ".") - 1)
            If .test(strExtName) Then
                dic(strFileName) = f.Path
            End If
        Next
    End With
   
    strPath = ThisWorkbook.Path & "\"
    br = [{9,6;5,6;5,12;6,6;3,3;3,9;3,12;4,6;6,12}]
    cr = Array(1, 2, 3, 4, 5, 6, 9, 11, 12)
    ar = [A1].CurrentRegion.Value
    Set wks = Worksheets("附表1 (2)")
   
    For i = 2 To UBound(ar)
        wks.Copy
        With ActiveWorkbook
            strFileName = strPath & ar(i, 1)
            With .Worksheets(1)
                For j = 1 To UBound(br)
                    .Cells(br(j, 1), br(j, 2)).Value = ar(i, cr(j - 1))
                Next j
                If dic.exists(ar(i, 1)) Then
                      .Cells(3, 15).Select
                      With .Pictures.Insert(dic(ar(i, 1)))
                          .ShapeRange.LockAspectRatio = msoTrue
                          .Left = Selection.Left + 2
                          .Top = Selection.Top + 2
                          .Height = Selection.Height - 4
                     End With
                End If
            End With
            .SaveAs strFileName
            .Close
        End With
    Next i
   
    Set wks = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Beep
End Sub

gwjkkkkk

请参考 。。。

sandays

建议邮件合并