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

249011132

     请教各位大侠如何通过公式或者VB实现按照对应的身份证号，导入 照片 目录下  "身份照.jpg" 图片到E、K 位置上，并根据单元格的大小自动调整图片大小。
直接上附件！！！
电子档案.rar (22.06 KB, 下载次数: 18)

2017-11-22 21:10 上传

点击文件名下载附件

大神们帮我弄弄谢谢了！
如果是VB最好能给解释下 语句的意思哈 便于学习

249011132

我在单元格 O4 中加入公式对花名册B列计数（=COUNTA(在校生花名册!$B$5:$B$99999)）
然后 对变量  For i = 1 To 20  赋值，这个20 改成 固定值即单元格O4的值，如何调整？  解决了  For i = 1 To Range("o" & 4).Value
现在还有个问题 如何批量删除已经插入的图片呢？？？

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

朱荣兴 发表于 2017-11-22 21:58
我的主题中就有这种贴子，自己搜搜看看

10几页的记录看完了 没找到。。。

szqhb

你设置那张“电子档案”的目的是什么？是打印裁剪得到每个同学的小卡片；打印所有的卡片用于存档；仅当显示每个人的小卡片？

249011132

szqhb 发表于 2017-11-23 10:18
你设置那张“电子档案”的目的是什么？是打印裁剪得到每个同学的小卡片；打印所有的卡片用于存档；仅当显示 ...

是的，就是这样子

szqhb

仅仅要打印存档（或者裁剪小卡片）的话，可以用Word的邮件合并来实现。有空帮你弄一个。函数或者VBA不熟。

249011132

szqhb 发表于 2017-11-23 11:32
仅仅要打印存档（或者裁剪小卡片）的话，可以用Word的邮件合并来实现。有空帮你弄一个。函数或者VBA不熟。

邮件合并我熟悉，我现在想借助这个 对VB学习下，谢谢了

zopey

电子档案22.zip (35.67 KB, 下载次数: 26)

2017-11-23 11:45 上传

点击文件名下载附件

249011132

zopey 发表于 2017-11-23 11:45

测试了 很好用，但是问题来了，我这个表格数据条目不一定 有的有1000+有的只有100+  
我现在应该如何处理呢  能否实现 按照 在校生花名册 中的数据行数 来自动插入到电子档案中对应的数据呢？