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

自由！自在 · 发表于 2023-3-28 20:06

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

蓝桥玄霜 · 发表于 2023-3-29 10:00

图片的例子：

3190496160 · 发表于 2023-3-29 12:04

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

chzsh · 发表于 2023-3-29 14:08

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

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

蓝桥玄霜 · 发表于 2023-3-30 09:42

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 <> ""
d(myName) = ""
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

复制代码

chzsh · 发表于 2023-3-30 10:47

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 · 发表于 2023-4-3 12:16

本帖最后由 chengyunpan 于 2023-4-3 12:22 编辑

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

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

自由！自在 · 发表于 2023-4-4 14:22

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

软件简介：

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

		自动登录	找回密码
密码			免费注册

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

评分