证件卡等中如何批量导入照片

zopey

熟悉插入图片的基本代码后，自然可以灵活修改。

jiaxinl

249011132 发表于 2017-11-23 12:34
我在单元格 O4 中加入公式对花名册B列计数（=COUNTA(在校生花名册!$B$5:$B$99999)）
然后 对变量  For i = ...

请见附件和动态图

Private Sub CommandButton1_Click()
With CommandButton1
   If .Caption = "清除" Then
      Call 清除
      .Caption = "批量处理"
      .BackColor = &H80FF&
      .Width = 87
      .Height = 25.5
      .Left = 670
      .Top = 6
      Exit Sub
   End If
   If .Caption = "批量处理" Then
      Call 批量处理
      .Caption = "清除"
      .BackColor = &HFF00&
      .Width = 87
      .Height = 25.5
      .Left = 670
      .Top = 6
      Exit Sub
   End If
End With
End Sub


Sub 批量处理()
Dim FSO, arr, Pic As Picture, shp As Shape, sPath$, sFilePath$, i&, k&
Application.ScreenUpdating = False
arr = Sheet3.Range("A5:P" & Sheet3.Cells(Rows.Count, 1).End(xlUp).Row)
For Each shp In Sheet2.Shapes
   If shp.Type <> 12 Then shp.Delete
Next
Set FSO = CreateObject("Scripting.FileSystemObject")
sPath = ThisWorkbook.Path & "\照片\"
With Sheet2
   For i = 2 To UBound(arr) Step 2
      k = i / 2
      Sheet4.Rows("1:4").Copy .Rows(k * 5 - 4)
      For j = i - 1 To i
         If j = i - 1 Then c1 = 2: c2 = 4: c3 = 5 Else c1 = 8: c2 = 10: c3 = 11
         .Cells(k * 5 - 4, c1) = arr(j, 1)
         .Cells(k * 5 - 4, c2) = arr(j, 2)
         .Cells(k * 5 - 3, c1) = arr(j, 3)
         .Cells(k * 5 - 3, c2) = arr(j, 7)
         .Cells(k * 5 - 2, c1) = arr(j, 15)
         .Cells(k * 5 - 2, c2) = arr(j, 9)
         .Cells(k * 5 - 1, c1) = arr(j, 6) & Chr(13)
         .Cells(k * 5 - 1, c2) = arr(j, 10)
         sFilePath = sPath & arr(j, 6) & ".jpg"
         If FSO.FileExists(sFilePath) Then
            Set Pic = .Pictures.Insert(sFilePath)
            With Pic
               .Placement = xlMoveAndSize
               .ShapeRange.LockAspectRatio = msoFalse
               .Width = Sheet2.Cells(k * 5 - 4, c3).MergeArea.Width - 4
               .Height = Sheet2.Cells(k * 5 - 4, c3).MergeArea.Height - 4
               .Top = Sheet2.Cells(k * 5 - 4, c3).MergeArea.Top + 2
               .Left = Sheet2.Cells(k * 5 - 4, c3).MergeArea.Left + 2
            End With
         End If
      Next j
  Next i
End With
End Sub

Sub 清除()
Dim shp As Shape
With Sheet2
   For Each shp In .Shapes
      If shp.Type <> 12 Then shp.Delete
   Next
   .Columns("A:K").Clear
   .Rows("1:" & .Rows.Count).RowHeight = 17
End With
End Sub

249011132

jiaxinl 发表于 2017-11-23 15:18
请见附件和动态图

Private Sub CommandButton1_Click()

非常感谢！！！完全符合

自由！自在

jiaxinl 发表于 2017-11-23 15:18
请见附件和动态图

Private Sub CommandButton1_Click()

这个表怎么能把生成的内容单独工作表？