如何实现利用工号从原数据导入数据后，依照姓名批量生产新工作簿

zichen77025

请教各位大佬：
功能类似WORD的邮件功能，
现在模板在K1处输入工号，会导入相关数据至模板中。
想实现功能：批量输入工号，依照姓名生成新的表格。

人员基础信息表(2021).rar (10.33 KB, 下载次数: 4)

2021-4-23 22:10 上传

点击文件名下载附件

3190496160

帖子标题 是要生成 工作簿，说明中又是要生成表格，你究竟是要生成工作表，还是工作簿？？？？

3190496160

Sub 生成工作簿()
With Sheets("源数据")
    r = .Cells(Rows.Count, 2).End(xlUp).Row
    ar = .Range("b2:c" & r)
End With
For i = 2 To UBound(ar)
    If Trim(ar(i, 1)) <> "" Then
        With Sheets("模板")
            .[k1] = ar(i, 1)
            .Copy
            ActiveWorkbook.Worksheets(1).UsedRange = ActiveWorkbook.Worksheets(1).UsedRange.Value
            ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & ar(i, 1) & "_" & ar(i, 2) & ".xls"
            ActiveWorkbook.Close
        End With
    End If
Next i
MsgBox "ok!"
End Sub

约定的童话

Sub 一箭双雕()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim i, n, k, a, t, arr, brr
    arr = [a1].CurrentRegion
    brr = Sheets("地址").[a1].CurrentRegion
    On Error Resume Next
    For i = 6 To UBound(arr) - 1
        t = arr(i, 1) & "-调查表"
        t1 = arr(i, 1) & "-登记簿 "
        For s = 2 To UBound(brr)
            If brr(s, 2) = arr(i, 5) And brr(s, 5) = arr(i, 9) Then
                Sheet2.[l4] = brr(s, 7) '电话
                Sheet2.[c5] = brr(s, 6) '地址
                Sheet3.[c13] = brr(s, 7) '电话
                Sheet3.[c12] = brr(s, 6) '地址
                Exit For
            End If
        Next
        Sheet2.[l3] = arr(i, 1)  '承包方编码(缩略码)
        Sheet2.[c4] = arr(i, 2) '承包方代表
        Sheet2.[j6] = arr(i, 9) '身份证号
        Sheet2.[m13] = "共_" & arr(i, 3) & "_人" '家庭成员数
        Sheet3.[c9] = [q2] & arr(i, 1) & "J" '承包方编码(缩略码)
        Sheet3.[c10] = arr(i, 2) '承包方代表
        Sheet3.[c11] = arr(i, 9) '身份证号
        Sheet3.[c15] = [q2] & arr(i, 1) & "J" '合同代码
        Sheet3.[a5] = "农村土地承包经营权登记簿代码：" & [q2] & arr(i, 1) & "J" '合同代码
        Sheet3.[c17] = arr(i, 20) '合同总面积
        Sheet3.[c18] = arr(i, 13) '地块总数
        Sheet2.[a15:f23] = ""
        Sheet3.[a22:h30] = ""
        For n = i + 1 To UBound(arr)
            If arr(n, 1) <> "" Then a = n - 1: Exit For
        Next
        m = 15: m1 = 22
        For k = i To a
            Sheet2.Cells(m, 1) = arr(k, 5)
            Sheet2.Cells(m, 4) = arr(k, 10)
            Sheet2.Cells(m, 6) = arr(k, 9)
            Sheet3.Cells(m1, 1) = arr(k, 5)
            Sheet3.Cells(m1, 3) = arr(k, 7)
            Sheet3.Cells(m1, 5) = arr(k, 10)
            Sheet3.Cells(m1, 6) = arr(k, 9)
            m = m + 1: m1 = m1 + 1
        Next
        Sheets("承包方").Copy
        ActiveSheet.Name = arr(i, 1)
        ActiveWorkbook.Close True, ThisWorkbook.Path & "\调查表\" & t & ".xlsx" '导出
        Sheets("承包经营权").Copy
        ActiveSheet.Name = arr(i, 1)
        ActiveWorkbook.Close True, ThisWorkbook.Path & "\登记簿\" & t1 & ".xlsx" '导出
        i = a
    Next
    MsgBox "制作完成！", 48, "温馨提示！"
End Sub
给你个之前的案例参考下。。。