Question

场景：我的Excel文件大约有120张。我每张纸使用了1页。页面大小为A6。所以，我在整个工作簿上有120个A6页面。

我需要做什么：我想制作一张A6页面大小，其中包含整个工作簿中的所有A6页面。然后我需要在A4尺寸的页面上打印（每张4 x A6页）。

问题：以下代码将所有工作表收集到一张工作表中。但问题是它将A6页面收集到“Letter”大小的页面。因此，当我点击打印预览时，它会在一张A4纸上显示20个小页面。当我选择A4时，每张纸应该只显示4页（因为，A4 = 4 X A6）。但为什么这会显示20页。它在A4上打印非常小的20页而不是4页。这不是打印机设置或页面设置问题，而是它自己生成这样一张表的代码。

Private Sub CommandButton1_Click()
Dim wshTemp As Worksheet, wsh As Worksheet
Dim rngArr() As Range, c As Range
Dim i As Integer
Dim j As Integer

ReDim rngArr(1 To 1)
For Each wsh In ActiveWorkbook.Worksheets
    i = i + 1
    If i > 1 Then   ' resize array
        ReDim Preserve rngArr(1 To i)
    End If

    On Error Resume Next
    Set c = wsh.Cells.SpecialCells(xlCellTypeLastCell)
    If Err = 0 Then
        On Error GoTo 0

        'Prevent empty rows
        Do While Application.CountA(c.EntireRow) = 0 _
          And c.EntireRow.Row > 1
            Set c = c.Offset(-1, 0)
        Loop

        Set rngArr(i) = wsh.Range(wsh.Range("A1"), c)
    End If
Next wsh

'Add temp.Worksheet
Set wshTemp = Sheets.Add(after:=Worksheets(Worksheets.Count))

On Error Resume Next
With wshTemp
    For i = 1 To UBound(rngArr)
        If i = 1 Then
            Set c = .Range("A1")
        Else
            Set c = _
              ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)
            Set c = c.Offset(2, 0).End(xlToLeft)  'Skip one row
        End If

        'Copy-paste range (prevent empty range)
        If Application.CountA(rngArr(i)) > 0 Then
            rngArr(i).Copy c
        End If
    Next i
End With
On Error GoTo 0

Application.CutCopyMode = False ' prevent marquies

With ActiveSheet.PageSetup     'Fit to 1 page
    .Zoom = False
    .FitToPagesWide = 1
    .FitToPagesTall = 1

End With

'Preview New Sheet
ActiveWindow.SelectedSheets.PrintPreview

'Print Desired Number of Copies
i = InputBox("Print how many copies?", "ExcelTips", 1)
If IsNumeric(i) Then
    If i > 0 Then
        ActiveSheet.PrintOut Copies:=i
    End If
End If

'Delete temp.Worksheet?
If MsgBox("Delete the temporary worksheet?", _
  vbYesNo, "ExcelTips") = vbYes Then
    Application.DisplayAlerts = False
    wshTemp.Delete
    Application.DisplayAlerts = True
End If
End Sub

Answer 1

变化

With ActiveSheet.PageSetup     'Fit to 1 page
    .Zoom = False
    .FitToPagesWide = 1
    .FitToPagesTall = 1

End With

到

With ActiveSheet.PageSetup     'Fit to 1 page
    .Zoom = 100
    .FitToPagesWide = 1
    .FitToPagesTall = 1

End With

Amalgamate A6尺寸纸张打印在A4尺寸页面上

1 个答案: