表格输出为PDF格式

风雨相随3

求助VBA代码：

拆分后的 成绩表.rar (862.39 KB, 下载次数: 4)

2024-12-15 17:09 上传

点击文件名下载附件

，录制宏没有代码。
并且因为表格太多，希望不弹出保存确认对话框。

quqiyuan

如何拆分，看到一个工作表，是不是这个工作表输出为一个PDF文件（看你写着拆分，不明白）

风雨相随3

quqiyuan 发表于 2024-12-15 17:29
如何拆分，看到一个工作表，是不是这个工作表输出为一个PDF文件（看你写着拆分，不明白）

是的，拆分后转成PDF. 另存为一个新的路径。

ykcbf1100

风雨相随3 发表于 2024-12-15 17:55
是的，拆分后转成PDF. 另存为一个新的路径。

关键是你没有说清楚，是按班级拆分还是按姓名拆分。

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub 拆分工作表()
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     p = ThisWorkbook.Path & ""
   
6.     Set sh = ThisWorkbook.Sheets("成绩")
   
7.     With sh
   
8.         r = .Cells(Rows.Count, 1).End(3).Row
   
9.         arr = .UsedRange
   
10.     End With
    
11.     For i = 3 To r
    
12.         d(arr(i, 1)) = ""
    
13.     Next
    
14.     For Each k In d.keys
    
15.         sh.Copy
    
16.         Set wb = ActiveWorkbook
    
17.         M = 0
    
18.         ReDim brr(1 To r, 1 To UBound(arr, 2))
    
19.         With wb.Sheets(1)
    
20.             .Name = k
    
21.             .DrawingObjects.Delete
    
22.             .UsedRange.Offset(2).ClearContents
    
23.             For i = 3 To UBound(arr)
    
24.                 If arr(i, 1) = k Then
    
25.                     M = M + 1
    
26.                     For j = 1 To UBound(arr, 2)
    
27.                         brr(M, j) = arr(i, j)
    
28.                     Next
    
29.                 End If
    
30.             Next
    
31.             .[a3].Resize(M, UBound(arr, 2)) = brr
    
32.             .UsedRange.Offset(M + 2).Clear
    
33.             .ExportAsFixedFormat xlTypePDF, p & "\班级" & k & ".pdf"
    
34.             wb.Close 0
    
35.         End With
    
36.     Next
    
37.     Set d = Nothing
    
38.     Application.ScreenUpdating = True
    
39.     MsgBox "OK！"
    
40. End Sub
    

复制代码

quqiyuan

重写了一遍，改用数组+字典，仅供参考。。。。
当弹出对话框，选择保存的文件夹。。

quqiyuan

代码如下。。。。
Sub test()
    Dim arr, d, k, i%, j%
    Dim sht As Worksheet
    Application.ScreenUpdating = False
   
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Title = "请选择PDF文件保存的文件夹。。。"
        .InitialFileName = ThisWorkbook.Path & "\"
        If .Show Then folderPath = .SelectedItems(1) & "\" Else Exit Sub
    End With
   
    With ThisWorkbook.Sheets("成绩")
        i = .Cells(.Rows.Count, 1).End(3).Row
        Set d = CreateObject("scripting.dictionary")
        arr = .Range("A1:L" & i)
        For i = 3 To UBound(arr)
            If Not d.exists(arr(i, 1)) Then Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
            d(arr(i, 1))(i) = ""
        Next
        kk = d.keys
        For Each k In d.keys
            Worksheets.Add after:=ThisWorkbook.ActiveSheet
            .Range("a1:l2").Copy ActiveSheet.Range("A1")
            .Range("a1:l2").Copy
            ActiveSheet.Range("A1").PasteSpecial xlPasteColumnWidths
            Application.CutCopyMode = False
            ActiveSheet.Name = k
            n = 0
            r = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(3).Row + 1
            ReDim brr(1 To 10000, 1 To UBound(arr, 2))
            For Each Key In d(k).keys
                n = n + 1
                For j = 1 To UBound(arr, 2)
                    brr(n, j) = arr(Key, j)
                Next
            Next
            ActiveSheet.Cells(r, 1).Resize(n, UBound(arr, 2)) = brr
            fileName = k & ".pdf"
'            ActiveSheet.PageSetup.PrintArea = ActiveSheet.[a1].CurrentRegion.Address
            ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:= _
                    folderPath & "\" & fileName, OpenAfterPublish:=False
        Next
        .Activate
    End With
    Set d = Nothing
    Application.ScreenUpdating = True
End Sub