按照人员信息表内容按行拆分并填充到模板内容并单独保存为工作簿

自由！自在

1、怎么把“人员信息”可以按照每行拆分分别填入“员工登记表”并且生成独立的excel文件，拆分后可以所有人员在一个工作薄也可以是按照每个人的名字独立工作簿，
拆分的时候可以选择拆分的行范围，因为人员有上千人，不是同时登记
2，在“员工登记表”对应范围按照身份证号自动插入照片（人员图像名称是身份证号码.jpg，身份证照片名称是身份证号码all.jpg）照片和工作簿不在同一个文件夹
哪位大神帮帮忙，

蓝桥玄霜

图片的例子：

3190496160

就在一个工作表中批量套打不行吗？何必要生成很多工作表或者工作簿呢？？

chzsh

蓝桥玄霜 发表于 2023-3-29 10:00
图片的例子：

生不成图片啊，哪里错了？

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, wz, myPath$, myName$, j%
   
3. Dim rng As Range, ML, MT, MW, MH
   
4. Dim d, k
   
5. Application.ScreenUpdating = False
   
6. Set d = CreateObject("Scripting.Dictionary")
   
7. myPath = ThisWorkbook.Path & "\员工身份证照片"
   
8. myName = Dir(myPath & "*.jpg")
   
9. Do While myName <> ""
   
10.     d(myName) = ""
    
11.     myName = Dir
    
12. Loop
    
13. k = d.keys
    
14. wz = Array("d2", "h2", "i5", "n2", "d3", "h3", "n3", "d4", "h4", "n4", "d5")
    
15. Sheet2.Activate
    
16. Arr = [b5].CurrentRegion
    
17. For i = 2 To UBound(Arr)
    
18.     Sheet1.Copy after:=Sheets(Sheets.Count)
    
19.     With ActiveSheet
    
20.      .Name = Arr(i, 1)
    
21.     For j = 0 To UBound(wz)
    
22.         .Range(wz(j)) = Arr(i, j + 1)
    
23.     Next
    
24.     If d.exists(Arr(i, 3) & ".jpg") Then
    
25.         Set rng = .[q2:q5]
    
26.         With rng
    
27.             ML = .Left + 1
    
28.             MT = .Top + 1
    
29.             MW = .Width - 2
    
30.             MH = .Height - 2
    
31.             ActiveSheet.Shapes.AddShape(msoShapeRectangle, ML, MT, MW, MH).Select
    
32.             Selection.ShapeRange.Fill.UserPicture myPath & Arr(i, 3) & ".jpg"
    
33.             Selection.ShapeRange.Line.Visible = msoFalse
    
34.         End With
    
35.     End If
    
36.     If d.exists(Arr(i, 3) & "all.jpg") Then
    
37.         Set rng = .[c14:h27]
    
38.         With rng
    
39.             ML = .Left
    
40.             MT = .Top
    
41.             MW = .Width
    
42.             MH = .Height
    
43.             ActiveSheet.Shapes.AddShape(msoShapeRectangle, ML, MT, MW, MH).Select
    
44.             Selection.ShapeRange.Fill.UserPicture myPath & Arr(i, 3) & "all.jpg"
    
45.             Selection.ShapeRange.Line.Visible = msoFalse
    
46.         End With
    
47.     End If
    
48.     End With
    
49. Next
    
50. 
    
51. Application.ScreenUpdating = True
    
52. End Sub

复制代码

chzsh

chzsh 发表于 2023-3-29 14:08
生不成图片啊，哪里错了？

解决了

Sub lqxs()
Dim Arr, i&, wz, myPath$, myName$, j%
Dim rng As Range, ML, MT, MW, MH
Dim d, k
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
myPath = ThisWorkbook.Path & "\员工身份证照片\"
myName = Dir(myPath & "*.jpg")
Do While myName <> ""
    If myName <> "" Then
    d(myName) = ""
    End If
    myName = Dir
Loop
k = d.keys
wz = Array("d2", "h2", "i5", "n2", "d3", "h3", "n3", "d4", "h4", "n4", "d5")
Sheet2.Activate
Arr = [b5].CurrentRegion
For i = 2 To UBound(Arr)
    Sheet1.Copy after:=Sheets(Sheets.Count)
    With ActiveSheet
     .Name = Arr(i, 1)
    For j = 0 To UBound(wz)
        .Range(wz(j)) = Arr(i, j + 1)
    Next
    If d.exists(Arr(i, 3) & ".jpg") Then
        Set rng = .[q2:q5]
        With rng
            ML = .Left + 1
            MT = .Top + 1
            MW = .Width - 2
            MH = .Height - 2
            ActiveSheet.Shapes.AddShape(msoShapeRectangle, ML, MT, MW, MH).Select
            Selection.ShapeRange.Fill.UserPicture myPath & Arr(i, 3) & ".jpg"
            Selection.ShapeRange.Line.Visible = msoFalse
        End With
    End If
    If d.exists(Arr(i, 3) & "all.jpg") Then
        Set rng = .[c14:h27]
        With rng
            ML = .Left
            MT = .Top
            MW = .Width
            MH = .Height
            ActiveSheet.Shapes.AddShape(msoShapeRectangle, ML, MT, MW, MH).Select
            Selection.ShapeRange.Fill.UserPicture myPath & Arr(i, 3) & "all.jpg"
            Selection.ShapeRange.Line.Visible = msoFalse
        End With
    End If
    End With
Next

Application.ScreenUpdating = True
End Sub

chengyunpan

万能套用软件用于楼主的案例（点设置，进行简单设置变变换功能就能拆分成独工作簿）

软件简介：   
     真正的软件级别，VBA通用软件，用于批量打印、拆分，用于特殊需求的录入、打印等等。不需改代码，就可以万能套用。复杂的数据引用、格式要求都能简单解决。
      单个、少量、批量操作（打印、拆分等）或者选择性操作都一样方便。
      核心很简单，就是用“=”号引用对应数据列，并作简单设置，一学就会，很容易套用到工作中遇到的实际案例。
       界面超级简单，千篇一律，傻瓜式操作。
      每个案例都仅是此软件的一个小应用，学会一个案例作参考就能一里通百里用，欢迎大家测试使用，更期待能提出宝贵意见。
     软件免费，并提供简单教程，需要做简单设计才能用到实际案例。也可以联系作者提供定制服务，小白也会用。
      文件就是软件！！！

自由！自在

chengyunpan 发表于 2023-4-3 12:16
万能套用软件用于楼主的案例（点设置，进行简单设置变变换功能就能拆分成独工作簿）

软件简介：   

身份证要上传两张，然后分别裁剪，和图像合起来就是一个表有三个照片，这个要怎么弄？