Định dạng Print area cho tất cả các sheet và nằm trong khổ giấy A4 (2 người xem)

[Thien]

Thân chào cả nhà!

Hiện tại mình có 1 file 100 sheet. Mình muốn định dạng như sau:
1/ Mình muốn định dạng Print area cho tất cả các sheet từ dòng cuối là tên của giám đốc lên A1
2/ Nội dung nằm trong khổ A4 đứng (các cột không được sang trang khác).
3/ Nếu các cột quá khỗ A4 đứng thì định dạng Adjust to xuống cho vừa trang A4.

Mong các thầy và bạn hữu gần xa xem giúp hộ.

Thân chào

 

[Thien]

Thân chào cả nhà

Các bạn vui lòng xem giúp hộ, mình đang rất cần xử lý vấn đề này.
Hiện tại mình có 1 code định dạng Print area cho 1 sheet thôi, mình muốn cho tất cả các sheet vẫn chưa được:
Sub PrintArea()
Dim CF As Long, CV As Long, RF As Long, RV As Long
Dim Col As Long, Rw As Long

With ActiveSheet
CF = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
CV = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
RF = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
RV = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Col = Application.WorksheetFunction.Max(CF, CV)
Rw = Application.WorksheetFunction.Max(RF, RV)

.PageSetup.PrintArea = "$A$1:" & Cells(Rw, Col).Address
End With
End Sub

Bên cạnh đó sau khi set PrintArea vẫn bị cột tràn sang trang khác, nên mình muốn code định dạng Adjust to xuống cho vừa trang A4.

Các bạn xem hộ

Thân chào

 

[ptm0412]

Ghi vào This Workbook hoặc vào module:

Sub SetPrintPage()
For Each sh In ThisWorkbook.Sheets
Rw = sh.[d12].End(xlDown).Row + 8
    With sh.PageSetup
        .PrintArea = "$A$1:$J$" & Rw
        .Orientation = xlPortrait
        .PaperSize = xlPaperA4

        .FitToPagesWide = 1
        .FitToPagesTall = False
 
    End With
Next
End Sub

 

[Thien]

Ghi vào This Workbook hoặc vào module:

Sub SetPrintPage()
For Each sh In ThisWorkbook.Sheets
Rw = sh.[d12].End(xlDown).Row + 8
    With sh.PageSetup
        .PrintArea = "$A$1:$J$" & Rw
        .Orientation = xlPortrait
        .PaperSize = xlPaperA4

        .FitToPagesWide = 1
        .FitToPagesTall = False
 
    End With
Next
End Sub

Thân chào.

Chân thành cảm ơn sự giúp đỡ. Hiện có vài trở ngại sau:
1/ Code chạy chưa set đúng các sheet (xem trong file đính kèm)
2/ Cdoe "Rw = sh.[d12].End(xlDown).Row + 8" mình chưa hiểu ý nghĩa của đoạn này,

Thân.

 

[ptm0412]

Câu lệnh "Rw = sh.[d12].End(xlDown).Row + 8" dựa vào form mẫu thực của file trước:
- Từ D12 đến dòng tổng cộng không có dòng trống (5, 6 sheet như nhau)
- Từ dòng tổng cộng đến dòng "tên giám đốc" là 8 dòng (mọi sheet như nhau)
Do thấy mọi sheet giống nhau nên tôi cho rằng nó có quy luật và phang 1 câu lệnh như thế.

Nếu từ dòng 65000 mà End(xlup) thì lại bị chuyện khác: Trong file mẫu lần trước, mỗi sheet có 1 dòng chả biết có sử dụng hay không, nằm ở dòng mấy trăm ấy, lại không cố định.

Bi giờ đưa file khác, có dòng trống bên trên dòng tổng cộng, lại còn giảm chỗ ký tên từ 8 dòng xuống còn 6 dòng, nên code chạy bậy đúng rồi.

Thiên xem giải quyết mấy chuyện trên: hoặc không chừa dòng trống trong báo cáo, hoặc không có dòng thừa ở dòng mấy trăm, hoặc ít nhất, cho biết dấu hiệu nhận biết dòng cuối, chẳng hạn như tên thực của ông giám đốc. Chứ mỗi trang 1 tên giám đốc khác nhau thì bó tay.

 

[Thien]

Câu lệnh "Rw = sh.[d12].End(xlDown).Row + 8" dựa vào form mẫu thực của file trước:
- Từ D12 đến dòng tổng cộng không có dòng trống (5, 6 sheet như nhau)
- Từ dòng tổng cộng đến dòng "tên giám đốc" là 8 dòng (mọi sheet như nhau)
Do thấy mọi sheet giống nhau nên tôi cho rằng nó có quy luật và phang 1 câu lệnh như thế.

Nếu từ dòng 65000 mà End(xlup) thì lại bị chuyện khác: Trong file mẫu lần trước, mỗi sheet có 1 dòng chả biết có sử dụng hay không, nằm ở dòng mấy trăm ấy, lại không cố định.

Bi giờ đưa file khác, có dòng trống bên trên dòng tổng cộng, lại còn giảm chỗ ký tên từ 8 dòng xuống còn 6 dòng, nên code chạy bậy đúng rồi.

Thiên xem giải quyết mấy chuyện trên: hoặc không chừa dòng trống trong báo cáo, hoặc không có dòng thừa ở dòng mấy trăm, hoặc ít nhất, cho biết dấu hiệu nhận biết dòng cuối, chẳng hạn như tên thực của ông giám đốc. Chứ mỗi trang 1 tên giám đốc khác nhau thì bó tay.

Thân Chào Anh.

Chúng ta lấy tên ông giám đốc làm dòng cuối cùng để set PrintArea nha. Nhưng có bất lợi là dòng này lại merge của 4 cột G:J.
Vậy nếu ta quy ước dòng cuối là dòng thứ 8 kể từ dòng TỔNG CỘNG ở cột D nha Anh.
Anh xem giúp hộ .



Thân.

 

[ptm0412]

Thiên xem lại: Dòng cuối là dòng 1011 và 1012, trên dòng đó cũng có tên giám đốc.

Thôi, lấy chuẩn là dòng "TỔNG CỘNG" và + 6
Với điều kiện: Tất cả các chữ "TỔNG CỘNG" ở tất cả các sheet phải giống nhau từng ký tự một, và không thừa khoảng trắng nào.

 Sub SetPrintPage()
For Each sh In ThisWorkbook.Sheets

Set Clls = sh.[d12:D1000].Find("T" & ChrW(7892) & "NG C" & ChrW(7896) & "NG")
Rw = Clls.Row + 6
    With sh.PageSetup
        .PrintArea = "$A$1:$J$" & Rw
        .Orientation = xlPortrait
        .PaperSize = xlPaperA4

        .FitToPagesWide = 1
        .FitToPagesTall = False
 
    End With
Next
End Sub

 

[Thien]

Thiên xem lại: Dòng cuối là dòng 1011 và 1012, trên dòng đó cũng có tên giám đốc.

Thôi, lấy chuẩn là dòng "TỔNG CỘNG" và + 6
Với điều kiện: Tất cả các chữ "TỔNG CỘNG" ở tất cả các sheet phải giống nhau từng ký tự một, và không thừa khoảng trắng nào.

 Sub SetPrintPage()
For Each sh In ThisWorkbook.Sheets

Set Clls = sh.[d12:D1000].Find("T" & ChrW(7892) & "NG C" & ChrW(7896) & "NG")
Rw = Clls.Row + 6
    With sh.PageSetup
        .PrintArea = "$A$1:$J$" & Rw
        .Orientation = xlPortrait
        .PaperSize = xlPaperA4

        .FitToPagesWide = 1
        .FitToPagesTall = False
 
    End With
Next
End Sub

Sao code báo lỗi Object variable or with block variable not set.
Anh chỉ hộ.

Thân

 

[ptm0412]

Đó là vì nó tìm không ra chuỗi "TỔNG CỘNG" (CHÍNH XÁC TỪNG KÝ TỰ) trong vùng D2:D1000
Thử thay 1.000 bằng 2.000, 10.000 xem sao?