如何把excel中c列的图片批量插入到word内乙方右边的格子中

zzpsx

CBWSY

Sub TEST()   fn = ThisWorkbook.Path & "\" & "如何把excel中c列的图片批量插入到word内乙方右边的格子中.docx"   Set WD = GetObject(fn)    For Each shp In ActiveSheet.Shapes        If shp.Type = 13 Then           If shp.TopLeftCell.Row = 2 Then '第二行签名图片才插入               shp.Copy           End If        End If    Next    WD.Parent.Visible = True    WD.tables(1).cell(1, 2).Select    WD.ActiveWindow.Selection.PasteAndFormat (wdFormatOriginalFormatting) '   WD.Close False    Set WD = Nothing End Sub '

CBWSY

Sub TEST()
  fn = ThisWorkbook.Path & "\" & "如何把excel中c列的图片批量插入到word内乙方右边的格子中.docx"
  Set WD = GetObject(fn)
   For Each shp In ActiveSheet.Shapes
       If shp.Type = 13 Then
          If shp.TopLeftCell.Row = 2 Then '第二行签名图片才插入
              shp.Copy
          End If
       End If
   Next
   WD.Parent.Visible = True
   WD.tables(1).cell(1, 2).Select
   WD.ActiveWindow.Selection.PasteAndFormat (wdFormatOriginalFormatting)
'   WD.Close False
   Set WD = Nothing
End Sub

zzpsx

CBWSY 发表于 2024-2-26 17:12
Sub TEST()
  fn = ThisWorkbook.Path & "\" & "如何把excel中c列的图片批量插入到word内乙方右边的格子中 ...

gwjkkkkk

每个人生成一份word文档？？？

zzpsx

gwjkkkkk 发表于 2024-2-26 18:49
每个人生成一份word文档？？？

是的，谢谢。不知道word的邮件合并是否能实现我的目的？

蓝桥玄霜

在word文件的乙方旁边加一个书签，在excel中录入代码，执行即可。

gwjkkkkk

zzpsx 发表于 2024-2-26 18:50
是的，谢谢。不知道word的邮件合并是否能实现我的目的？

Option Explicit
Sub test()
    Dim wdApp As Object, wdDoc As Word.Document, strFileName$, strPath$
    Dim ar, i&, strSaveName$, wdRange As Word.Range, shp As Shape, t#
   
    strPath = ThisWorkbook.Path & "\"
    strFileName = strPath & "如何把excel中c列的图片批量插入到word内乙方右边的格子中.docx"
    If Dir(strFileName) = "" Then MsgBox "指定的文件不存在，请检查！", vbExclamation: Exit Sub
   
    Application.ScreenUpdating = False
   
    t = Timer
    Set wdApp = CreateObject("Word.Application")
    Set wdApp = GetObject(, "Word.Application")
    If Err <> 0 Then
        Set wdApp = CreateObject("Word.Application")
    End If
   
    With [A1].CurrentRegion
        ar = .Value
        Set wdDoc = wdApp.Documents.Open(strFileName)
        Set wdRange = wdDoc.Content
        For i = 2 To UBound(ar)
            For Each shp In .Parent.Shapes
                If shp.Type = msoPicture Then
                    If Abs((shp.Left + shp.Width / 2) - (.Cells(i, 3).Left + .Cells(i, 3).Width / 2)) < (shp.Width + .Cells(i, 3).Width) / 2 _
                        And Abs((shp.Top + shp.Height / 2) - (.Cells(i, 3).Top + .Cells(i, 3).Height / 2)) < (shp.Height + .Cells(i, 3).Height) / 2 Then
                        With wdApp.Documents.Add
                            strSaveName = strPath & ar(i, 1)
                            wdRange.Copy
                            wdApp.Selection.Paste
                            .tables(1).Range.Cells(2).Select
                            shp.Copy
                            wdApp.Selection.Paste
                            .SaveAs strSaveName
                            .Close
                        End With
                        Exit For
                    End If
                End If
            Next shp
        Next i
        wdDoc.Close False
    End With
   
    If Err <> 0 Then wdApp.Quit
    Set wdApp = Nothing: Set wdDoc = Nothing: Set wdRange = Nothing
   
    Application.ScreenUpdating = True
    MsgBox "执行完毕!_用时:  " & Format(Timer - t, "0.00") & "  秒", 64
End Sub

gwjkkkkk

请参考附件。。。

zzpsx

问题已经解决，谢谢各位。