求助：自动填充通知

wnchgy

根据表一的“户编号”判断，户编号相同的人员，提取对应信息到通知。编号能自动生成。然后自动按户主名字命名，生成pdf。拜托了。

wnchgy

表1的数据只列举了38条，实际有10多万条，所以要能自动判断自动生成PDF

3190496160

表1中根本就没有性别，年龄   两项信息呀，如何处理呢？？

3190496160

Sub test()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
ar = Sheets("表一").[a1].CurrentRegion
For i = 3 To UBound(ar)
    If Trim(ar(i, 4)) <> "" Then
        d(Trim(ar(i, 4))) = ""
    End If
Next i
For Each k In d.keys
    n = 0
    ReDim br(1 To UBound(ar), 1 To 6)
    For i = 3 To UBound(ar)
        If Trim(ar(i, 4)) = k Then
            n = n + 1
            br(n, 1) = ar(i, 5)
            br(n, 2) = ar(i, 6)
            br(n, 5) = ar(i, 12)
            br(n, 6) = ar(i, 8)
            If Trim(ar(i, 12)) = "户主" Then
                hz = ar(i, 6)
            End If
            zz = ar(i, 9)
        End If
    Next i
    With Sheets("通知")
        .Range("a6:f27") = Empty
        .[b2] = k
        .[d2] = n
        .[b3] = hz
        .[b4] = zz
        .[a6].Resize(n, UBound(br, 2)) = br
        .Copy
    End With
   
    ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & hz & ".pdf" _
                          , Quality:=xlQualityMinimum, IncludeDocProperties:=False, IgnorePrintAreas _
                          :=False, OpenAfterPublish:=False
   ActiveWorkbook.Close False
Next k
End Sub

3190496160

自动填写通知.rar (22.27 KB, 下载次数: 9)

2020-4-28 10:39 上传

点击文件名下载附件

wnchgy

3190496160 发表于 2020-4-28 10:39

万分感谢！只是还想请把通知中的编号设置为1、2、3、4这种，有几个人就编到几。