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

Question

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

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

问题：以下代码将所有工作表收集到一张工作表中。但问题是它会将A6页面收集到“Letter”大小页面。所以，当我点击打印预览时，它会在一张A4纸上显示20个小页面。当我选择A4时，它应该每张仅显示4页（因为A4 = 4×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