一对多查询提取数据生成文件

hbszls

请教各位，1、格式设置自定义，不知道问题出在那儿。2、把公式改成VBA，能否做到以班级为单位每个学生生成一个文件。xlsx或者PDF，便于批量打印。

orr89

不是已经给你做好了，发在你上条提问了吗，每个学生都能生成一张PDF文件的打印。你运行了吗。Sub 批量生成单个学生体温表打印()
Set sht2 = Sheet2
arr = sht2.Range("a2:j" & sht2.[a60000].End(xlUp).Row)
    Dim dic, brr(1 To 100, 1 To 3)
    Set dic = CreateObject("scripting.dictionary")
    For a = 1 To UBound(arr)
        Key = arr(a, 1) & arr(a, 2)
        If Not dic.exists(Key) Then
            Set dic(Key) = CreateObject("scripting.dictionary")
            dic(Key)(Format(arr(a, 4), "m月d日")) = arr(a, 6) & "@" & arr(a, 7)
        Else
            dic(Key)(Format(arr(a, 4), "m月d日")) = arr(a, 6) & "@" & arr(a, 7)
        End If
    Next

    条件 = Sheet1.[f2] & Sheet1.[b3]
    日期 = dic(条件).keys
    For a = 0 To UBound(日期)
        n = n + 1
        内容 = Split(dic(条件)(日期(a)), "@")
        brr(n, 1) = Format(日期(a), "m月d日"): brr(n, 2) = 内容(0): brr(n, 3) = 内容(1)
    Next
    Range("a5:c100").ClearContents
    [a5].Resize(n, 3) = brr
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    "C:\Users\Administrator\Desktop\" & 条件 & ".pdf", Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
    True
End Sub

在给你一个点一次查一次并同时生成PDF在桌面的文件，如果要点一下一次性生成全部学生的，取上次提问里找，已经做好了。

aku2005

抄一半写一半

hbszls

orr89 发表于 2020-2-22 19:09
不是已经给你做好了，发在你上条提问了吗，每个学生都能生成一张PDF文件的打印。你运行了吗。Sub 批量生成 ...

谢谢，已经很好了。只是导出时只能导出最后一个学生的。我想实现的导出是，单独每个学生导出一个文件，还有以班级为单位导出一个文件。

orr89

hbszls 发表于 2020-2-23 10:18
谢谢，已经很好了。只是导出时只能导出最后一个学生的。我想实现的导出是，单独每个学生导出一个文件，还 ...

Sub 批量生成单个学生体温表打印()
Set sht2 = Sheet2
arr = sht2.Range("a2:j" & sht2.[a60000].End(xlUp).Row)
    Dim dic, brr(1 To 100, 1 To 3)
    Set dic = CreateObject("scripting.dictionary")
    For a = 1 To UBound(arr)
        Key = arr(a, 1) & arr(a, 2)
        If Not dic.exists(Key) Then
            Set dic(Key) = CreateObject("scripting.dictionary")
            dic(Key)(Format(arr(a, 4), "m月d日")) = arr(a, 6) & "@" & arr(a, 7)
        Else
            dic(Key)(Format(arr(a, 4), "m月d日")) = arr(a, 6) & "@" & arr(a, 7)
        End If
    Next
   
    条件 = Sheet1.[f2] & Sheet1.[b3]
    日期 = dic(条件).keys
    For a = 0 To UBound(日期)
        n = n + 1
        内容 = Split(dic(条件)(日期(a)), "@")
        brr(n, 1) = Format(日期(a), "m月d日"): brr(n, 2) = 内容(0): brr(n, 3) = 内容(1)
    Next
    Range("a5:c100").ClearContents
    [a5].Resize(n, 3) = brr
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    "C:\Users\Administrator\Desktop\" & [f2].Value & "\" & 条件 & ".pdf", Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
    True
End Sub
自己在桌面把每个班级的文件夹建好，然后就会自动在此文件夹下简历对应的学生，其他路径请自行更换。

blackttea1

学习啦，谢谢