- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
4#
發表於 2012-8-23 10:29
| 只看該作者
回復 3# dechiuan999
依1#附檔 第一個表格所寫, 試試看- Option Explicit
- Dim Sh As Worksheet, Rng As Range
- Sub 按鈕() '按紐指定的程式
- Dim 印列 As String
- Set Sh = ActiveSheet
- Set Rng = Sh.[A1:G20] '表格範圍
- Do
- 印列 = InputBox("印列表格: 請輸入 1 或 2 ", "印列表格")
- Loop Until 印列 = "1" Or 印列 = "2" Or 印列 = ""
- If 印列 = "1" Then
- With Sh
- .PageSetup.PrintArea = Rng.Address
- .PageSetup.FitToPagesTall = 1
- .PageSetup.FitToPagesWide = 1
- .PrintOut
- End With
- ElseIf 印列 = "2" Then
- 二張表格
- End If
- End Sub
- Private Sub 二張表格()
- Dim R As Range, ActionShape As String, i As Integer
- With Sh
- ActionShape = .Shapes(Application.Caller).Name '執行此程式的按鈕名稱
- '---此行程式碼 按F5 或 F8 會有錯誤 需是在工作表按下 [按鈕] 執行 ----
- Application.ScreenUpdating = False
- Rng.Copy Rng.Offset(Rng.Rows.Count) '複製表格
- For Each R In Rng.Rows '
- R.Offset(20).RowHeight = R.RowHeight '複製表格:調整列高與表格 相同
- Next
- .PageSetup.PrintArea = .Range(Rng, Rng.Offset(Rng.Rows.Count)).Address
- '設定印列範圍
- .PageSetup.FitToPagesTall = 1
- .PageSetup.FitToPagesWide = 1
- '.PrintPreview '印列預覽
- .PrintOut '印列
- For i = .Shapes.Count To 2 Step -1 '刪除圖片:片由後刪除到第2個
- If .Shapes(i).Name <> ActionShape Then .Shapes(i).Delete
- '排除Shape是指定程式按紐的Shape
- Next
- Rng.Offset(Rng.Rows.Count).Clear '清除: 複製表格
- Rng.Offset(Rng.Rows.Count).RowHeight = .Cells(.Rows.Count).RowHeight
- '回復列高
- .PageSetup.PrintArea = Rng.Address '回復印列範圍
- Application.ScreenUpdating = True
- End With
- End Sub
複製代碼 |
|