vba Excel - 将多个工作表中的单元格范围保存为没有空格的pdf

Excel - save range of cells in multiple sheets to pdf with no whitespace

提问by Simon Watson

First timer here! I've got a spreadsheet which uses multiple worksheets, each sheet formatted like this:

第一次来这里！我有一个使用多个工作表的电子表格，每个工作表的格式如下：

**Sheet 1**

Name            Assessment Item 1    Assessment Item 2
Student Name    Feedback Item 1      Feedback Item 2
Student Name    Feedback Item 1      Feedback Item 2

**Sheet 2**

Name            Assessment Item 1    Assessment Item 2
Student Name    Feedback Item 1      Feedback Item 2
Student Name    Feedback Item 1      Feedback Item 2

I want to be able to export the title row and one student row (across all sheets) per pdf. It would mean combining the title row and the 8 student rows (one per sheet) into one sheet, and exporting, I'm thinking.

我希望能够为每个 pdf 导出标题行和一个学生行（跨所有工作表）。这意味着将标题行和 8 个学生行（每张一张）合并到一张纸中，然后导出，我在想。

I've been using this code:

我一直在使用这个代码：

Sub copyValueTable()

ThisWorkbook.Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select

ActiveSheet.Range("A1:F2").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\First.pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, _
 IgnorePrintAreas:=False, OpenAfterPublish:=True

ActiveSheet.Range("A1:F1,A3:F3").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Second.pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, _
 IgnorePrintAreas:=False, OpenAfterPublish:=True

End Sub

...and it does what I want, but (a) the pdf has one sheet per page, which means a lot of whitespace, (b) it doesn't all fit to one page, so formatting goes awry, and (c) I'd like it to be more automated, if possible, so that I don't have to create an activesheet range for each of my 150 students...

...它做了我想要的，但是 (a) pdf 每页有一张纸，这意味着很多空白，(b) 它并不适合一页，所以格式出错了，并且 (c ) 如果可能的话，我希望它更加自动化，这样我就不必为我的 150 名学生中的每一个都创建一个活动表范围......

Any ideas would be greatly appreciated!

任何想法将不胜感激！

Watto :)

瓦托 :)

采纳答案by ChrisProsser

Revised answer following clarifications in comments (further revised for formatting):

根据评论中的澄清修改答案（进一步修改格式）：

Sub copyValueTable()

    Dim ws As Worksheet
    Dim heads
    Dim new_sheet As Worksheet
    Dim rownum
    Dim ns_rownum
    Dim filename
    Dim filepath
    Dim rowcnt

    ' add a new workbook for the summary...
    Set new_sheet = Sheets.add
    rownum = 1
    rowcnt = Sheets(2).Range("A1").End(xlDown).row

    ' loop through rows in outer loop
    For rownum = 2 To rowcnt
        Debug.Print "..on student row " & rownum & " in outer loop..."
        ns_rownum = 1 ' initialise for loop through sheets

        ' loops through sheets (except new)...
        For Each ws In Worksheets
            If ws.Name <> new_sheet.Name Then
                Debug.Print "....on sheet " & ws.Name & " in inner loop..."

                ' copy heads...
                ws.Rows(1).Copy new_sheet.Rows(ns_rownum)
                ns_rownum = ns_rownum + 1

                ' copy data for current record (paste to ns_rownum row to allow for other sheets)
                ws.Rows(rownum).Copy
                new_sheet.Rows(ns_rownum).PasteSpecial Paste:=xlPasteAll

                ' paste column widths to new sheet on first pass through each sheet
                If rownum = 2 Then
                    ws.Columns("A:Z").Copy
                    new_sheet.Columns("A:Z").PasteSpecial Paste:=xlPasteColumnWidths
                End If

                ns_rownum = ns_rownum + 2
            End If
        Next

        ' write to pdf
        filename = Sheets(2).Range("A" & rownum).Value
        filepath = Environ("userprofile") & "\" & filename & ".pdf"
        new_sheet.Rows("1:" & ns_rownum).ExportAsFixedFormat Type:=xlTypePDF, _
         filename:=filepath, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
         IgnorePrintAreas:=False, OpenAfterPublish:=True

        ' delete data in tmp sheet other than heads ready for next loop through sheets
        Sheets(1).Rows("2:" & ns_rownum).Delete

    Next rownum

    ' clean up
    Application.DisplayAlerts = False
    new_sheet.Delete
    Application.DisplayAlerts = True
    Set new_sheet = Nothing
    Set ws = Nothing

End Sub

You will need to replace 'Environ("userprofile")' with the path that you want to use for the pdf files, this will pick up the Windows environment variable for the current users default directory.

您需要将 'Environ("userprofile")' 替换为要用于 pdf 文件的路径，这将为当前用户的默认目录选择 Windows 环境变量。

This revised script above adds a new temp sheet, takes the heads from the 2nd sheet (as the temp will now be the first) then loops through all rows on 2nd sheet (assuming that the other sheets have the same no of rows as there is one row per student on each). Within this there is an inner loop through the sheets to take the row corresponding to the current student and copy this to the tmp sheet. The Tmp sheet is then exported as a PDF and cleared down ready for the next student.

上面这个修改后的脚本添加了一个新的临时表，从第二张表中取出头部（因为临时表现在将是第一个）然后循环遍历第二张表上的所有行（假设其他表具有相同的行数）每个学生每个人排一排）。其中有一个通过工作表的内部循环，以获取与当前学生对应的行并将其复制到 tmp 工作表。然后将 Tmp 表导出为 PDF 并清理干净以供下一个学生使用。

Please note the assumptions above around each student being on the same row on each sheet. If this is not correct then another mechanism would be required to select from the appropriate rows.

请注意上述关于每个学生在每张纸上的同一行的假设。如果这不正确，则需要另一种机制从适当的行中进行选择。

I have copied column widths for columns A:Z, you can adjust the column letters to your requirements.

我已经复制了 A:Z 列的列宽，您可以根据您的要求调整列字母。

Hope this helps.

希望这可以帮助。