Co, Dãn dòng vừa trang in (2 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 2 (Thành viên: 1, Khách: 1)
Tôi tuân thủ nội quy khi đăng bài
Có
vova2209

vova2209

Thành viên tích cực
Tham gia
5/4/17
Bài viết
846
Được thích
112
Giới tính
Nam
Nghề nghiệp
Đường bộ
Em chào Anh Chị!
Anh Chị sử lý giúp em dãn chiều cao dòng cho vừa trang in như hình mô tả bên dưới và file đính kèm:
- Em đã sử lý code ẩn dòng trống và dãn dòng ở mục "4 Nội dung công việc thực hiện:"
- File của em khi co dãn ẩn dòng trống thì bị phần tên lòi sang trang 2 mỗi tên ký
- Sử lý giúp em co chiều cao dòng phần nội dung lại với điều kiện giá trị tối thiểu ghi ở ô A4=18, nếu co lại chiều cao dòng 18 mà vừa 1 trang in là được
- Nếu co lại chiều cao tối thiểu là 18 rồi mà vẫn không vừa lại 1 trang in thì dãn chiều cao dòng tăng dần lên 19..20..21..22..... đến khi phần nội dung sang trang 02, 1 hoặc 2 dòng là được
- Chỉ co lại hoặc dãn ra đối với dòng 1 dòng, không co dãn dòng đã tăng chiều cao 2 dòng, 3 dòng.
-> Anh Chị giúp em ạ, em cảm ơn

1.JPG2.JPG3.JPG
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
Anh Chị nào rảnh bớt chút thời gian sử lý giúp em với ạ, em cảm ơn :fish:
 
Upvote 0
vova2209 đã viết:
Anh Chị nào rảnh bớt chút thời gian sử lý giúp em với ạ, em cảm ơn :fish:
Nhấp chuột vào đây để mở rộng...
Sao?bạn đã có giải pháp chạy được rối mà.
Tôi đưa file của bạn nhờ tôi làm giúp mà tôi đã làm nhé. Hy vọng có người xem được và biết đâu họ có ý kiến hoặc sửa lại thì chẳng phải là tốt hơn sao.
 

File đính kèm

Upvote 0
HUONGHCKT đã viết:
Sao?bạn đã có giải pháp chạy được rối mà.
Tôi đưa file của bạn nhờ tôi làm giúp mà tôi đã làm nhé. Hy vọng có người xem được và biết đâu họ có ý kiến hoặc sửa lại thì chẳng phải là tốt hơn sao.
Nhấp chuột vào đây để mở rộng...
file này em chạy vẫn bị như cũ. vẫn bị lòi mỗi chữ ký sang trang không co lại hoặc giãn ra ạ
 
Upvote 0
vova2209 đã viết:
Anh Chị nào rảnh bớt chút thời gian sử lý giúp em với ạ, em cảm ơn :fish:
Nhấp chuột vào đây để mở rộng...
Bạn thử chạy Sub này, điều kiện là các dòng ẩn bên dưới phải là rỗng (không chứa công thức)
Rich (BB code): 
Sub FitTableContent()
    Dim ws As Worksheet
    Dim Rng As Range
    Dim h As Double
    Dim pb As HPageBreak
    Dim FRw&, LRw&, i&, Rw&
    
    Set ws = ActiveSheet
    
    FRw = 12
    LRw = Cells.Find(What:="5.", LookIn:=xlFormulas, LookAt:=xlPart).Row - 1
    
    For i = FRw To LRw
        If Len(ws.Range("B" & i)) > 0 Then
            If Len(ws.Range("B" & i)) < 105 Then
                If Rng Is Nothing Then
                    Set Rng = ws.Range("B" & i).EntireRow
                Else
                    Set Rng = Union(Rng, ws.Range("B" & i).EntireRow)
                End If
            End If
        End If
    Next
    
    h = 18
    Rng.RowHeight = h
    Rw = ws.Range("B" & LRw + 1).End(xlUp).Row
    
    If ws.HPageBreaks.Count = 1 Then
        Set pb = ws.HPageBreaks(1)
        Do Until pb.Location.Row = Rw
            h = h + 1
            Rng.RowHeight = h
        Loop
    End If
End Sub
 
Upvote 0
Maika8008 đã viết:
Bạn thử chạy Sub này, điều kiện là các dòng ẩn bên dưới phải là rỗng (không chứa công thức)
Rich (BB code): 
Sub FitTableContent()
    Dim ws As Worksheet
    Dim Rng As Range
    Dim h As Double
    Dim pb As HPageBreak
    Dim FRw&, LRw&, i&, Rw&
    
    Set ws = ActiveSheet
    
    FRw = 12
    LRw = Cells.Find(What:="5.", LookIn:=xlFormulas, LookAt:=xlPart).Row - 1
    
    For i = FRw To LRw
        If Len(ws.Range("B" & i)) > 0 Then
            If Len(ws.Range("B" & i)) < 105 Then
                If Rng Is Nothing Then
                    Set Rng = ws.Range("B" & i).EntireRow
                Else
                    Set Rng = Union(Rng, ws.Range("B" & i).EntireRow)
                End If
            End If
        End If
    Next
    
    h = 18
    Rng.RowHeight = h
    Rw = ws.Range("B" & LRw + 1).End(xlUp).Row
    
    If ws.HPageBreaks.Count = 1 Then
        Set pb = ws.HPageBreaks(1)
        Do Until pb.Location.Row = Rw
            h = h + 1
            Rng.RowHeight = h
        Loop
    End If
End Sub
Nhấp chuột vào đây để mở rộng...
Vâng để em thử. em cảm ơn ạ
 
Upvote 0
vova2209 đã viết:
Vâng để em thử. em cảm ơn ạ
Nhấp chuột vào đây để mở rộng...
Sửa logic giải thuật lại 1 chút:
Rich (BB code): 
Sub FitTableContent()
    Dim ws As Worksheet
    Dim Rng As Range
    Dim h As Double
    Dim pb As HPageBreak
    Dim FRw&, LRw&, i&, Rw&, EndRw&
    
    Set ws = ActiveSheet
    
    FRw = 12
    If Cells.Find(What:="5.", LookIn:=xlFormulas, LookAt:=xlPart) Is Nothing Then
        MsgBox "Không tim thây chuoi '5.'": Exit Sub
    Else
        LRw = Cells.Find(What:="5.", LookIn:=xlFormulas, LookAt:=xlPart).Row - 1
    End If
    
    For i = FRw To LRw
        If Len(ws.Range("B" & i)) > 0 Then
            If Len(ws.Range("B" & i)) < 105 Then
                If Rng Is Nothing Then
                    Set Rng = ws.Range("B" & i).EntireRow
                Else
                    Set Rng = Union(Rng, ws.Range("B" & i).EntireRow)
                End If
            End If
        End If
    Next
    
    h = 18
    Rng.RowHeight = h
    Rw = ws.Range("B" & LRw + 1).End(xlUp).Row - 1
    EndRw = LRw + 10
    
    On Error Resume Next
    Set pb = ws.HPageBreaks(ws.HPageBreaks.Count)
    
    If pb Is Nothing Then GoTo End_
    
    If EndRw >= pb.Location.Row Then
        If pb.Location.Row > Rw Then
            Do Until pb.Location.Row <= Rw And h < 34
                h = h + 1
                Rng.RowHeight = h
            Loop
        End If
    End If

End_:
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Đặt Print Area và chọn co vừa trang chiều cao là 1 trang là được
Thủ tục giãn dòng không đủ điều kiện để giãn dòng chính xác nhất.
Không tính Scale dẫn đến đặt chiều rộng ô gộp sai.
 
Lần chỉnh sửa cuối:
Upvote 0
HeSanbi đã viết:
Đặt Print Area và chọn co vừa trang chiều cao là 1 trang là được
Thủ tục giãn dòng không đủ điều kiện để giãn dòng chính xác nhất.
Không tính Scale dẫn đến đặt chiều rộng ô gộp sai.
Nhấp chuột vào đây để mở rộng...
Nhật ký có rất nhiều dòng công việc, theo như file mẫu thì đến 58 dòng và đã đặt Print Area. Nếu dùng hết các dòng thì mẫu in sẽ có 2 trang, nếu co lại thành 1 thì in ra không ổn. Do vậy buộc phải co giãn như yêu cầu của thớt là hợp lý mà.
 
Upvote 0
Maika8008 đã viết:
Sửa logic giải thuật lại 1 chút:
Rich (BB code): 
Sub FitTableContent()
    Dim ws As Worksheet
    Dim Rng As Range
    Dim h As Double
    Dim pb As HPageBreak
    Dim FRw&, LRw&, i&, Rw&, EndRw&
   
    Set ws = ActiveSheet
   
    FRw = 12
    If Cells.Find(What:="5.", LookIn:=xlFormulas, LookAt:=xlPart) Is Nothing Then
        MsgBox "Không tim thây chuoi '5.'": Exit Sub
    Else
        LRw = Cells.Find(What:="5.", LookIn:=xlFormulas, LookAt:=xlPart).Row - 1
    End If
   
    For i = FRw To LRw
        If Len(ws.Range("B" & i)) > 0 Then
            If Len(ws.Range("B" & i)) < 105 Then
                If Rng Is Nothing Then
                    Set Rng = ws.Range("B" & i).EntireRow
                Else
                    Set Rng = Union(Rng, ws.Range("B" & i).EntireRow)
                End If
            End If
        End If
    Next
   
    h = 18
    Rng.RowHeight = h
    Rw = ws.Range("B" & LRw + 1).End(xlUp).Row - 1
    EndRw = LRw + 10
   
    On Error Resume Next
    Set pb = ws.HPageBreaks(ws.HPageBreaks.Count)
   
    If pb Is Nothing Then GoTo End_
   
    If EndRw >= pb.Location.Row Then
        If pb.Location.Row > Rw Then
            Do Until pb.Location.Row <= Rw And h < 34
                h = h + 1
                Rng.RowHeight = h
            Loop
        End If
    End If

End_:
End Sub
Nhấp chuột vào đây để mở rộng...
Chạy nuột. chỉ là những dòng nào có hàm trả về 0 là bị hiện lên. em cảm ơn.
 
Upvote 0
Maika8008 đã viết:
Sửa logic giải thuật lại 1 chút:
Rich (BB code): 
Sub FitTableContent()
    Dim ws As Worksheet
    Dim Rng As Range
    Dim h As Double
    Dim pb As HPageBreak
    Dim FRw&, LRw&, i&, Rw&, EndRw&
   
    Set ws = ActiveSheet
   
    FRw = 12
    If Cells.Find(What:="5.", LookIn:=xlFormulas, LookAt:=xlPart) Is Nothing Then
        MsgBox "Không tim thây chuoi '5.'": Exit Sub
    Else
        LRw = Cells.Find(What:="5.", LookIn:=xlFormulas, LookAt:=xlPart).Row - 1
    End If
   
    For i = FRw To LRw
        If Len(ws.Range("B" & i)) > 0 Then
            If Len(ws.Range("B" & i)) < 105 Then
                If Rng Is Nothing Then
                    Set Rng = ws.Range("B" & i).EntireRow
                Else
                    Set Rng = Union(Rng, ws.Range("B" & i).EntireRow)
                End If
            End If
        End If
    Next
   
    h = 18
    Rng.RowHeight = h
    Rw = ws.Range("B" & LRw + 1).End(xlUp).Row - 1
    EndRw = LRw + 10
   
    On Error Resume Next
    Set pb = ws.HPageBreaks(ws.HPageBreaks.Count)
   
    If pb Is Nothing Then GoTo End_
   
    If EndRw >= pb.Location.Row Then
        If pb.Location.Row > Rw Then
            Do Until pb.Location.Row <= Rw And h < 34
                h = h + 1
                Rng.RowHeight = h
            Loop
        End If
    End If

End_:
End Sub
Nhấp chuột vào đây để mở rộng...
Chỉnh lại giúp em những dòng ở mục nội dung có công thức trả về không hoặc "" là đang bị unhide dòng lên ạ
 
Upvote 0
Vấn đề là đặt ngắt trang cho trang in, bạn đấy đã nghĩ cách là co giãn dòng để ngắt trang dịch chuyển, nhưng do thuật toán của Excel họ tính toán ngắt trang chứ không nên giãn dòng, nên dùng giải thuật ngắt trang thông minh
Giải thuật dưới đây là Đặt một vùng luôn luôn nằm trong một trang, nếu ngắt trang nằm giữa vùng đó thì dịch chuyển ngắt trang để vùng đó vừa trang

Đoạn mã này đã được chia sẻ trong Add-in FitRowXL trước đó, mã tự động hóa ngắt trang.
Đoạn mã này AI cũng không có khả năng viết ra, nhưng ngày nào đó AI quét được trang này, nó sẽ học được.


Mã này chạy trong vùng dữ liệu có đặt Vùng In (Print Area)
JavaScript: 
Private Sub FITPageBreaks_test()
  Dim cl As New Collection
  cl.Add [B71:E80]
 ' cl.Add [C42:AN59]
  Debug.Print FITPageBreaks(cl)
End Sub
Function FITPageBreaks(ByVal indexes As Collection, _
    Optional ByVal limitPageMinZoom% = 95, _
    Optional ByVal defaultPageZoom% = 100) As Boolean
  On Error Resume Next
  If indexes Is Nothing Then Exit Function
  If indexes.Count = 0 Then Exit Function
  Dim cell2, cell, prCell As Range, aCell As Range, sh As Worksheet, cl As New Collection
  For Each cell In indexes
    If TypeName(cell) = "Range" Then
      If sh Is Nothing Then
        Set sh = cell.Parent:
        If sh.HPageBreaks.Count = 0 Then Exit Function
        Set prCell = sh.Range(sh.PageSetup.PrintArea)
        Set aCell = cell: cl.Add cell
      Else
        If Intersect(aCell, cell) Is Nothing Then cl.Add cell
        Set aCell = Union(aCell, cell)
      End If
    End If
  Next
  If sh Is Nothing Then Exit Function
  Dim Page As HPageBreak, Pages%, iPage, lcr&, r&, lr&, lrs&, b As Boolean
  Dim pZoom%, tZoom%, lcCell As Range, area As Range, tRow As Range
  pZoom = sh.PageSetup.Zoom
  
  For Each area In prCell.Areas
    For Each cell2 In cl
      r = cell2.Row: lr = cell2.Rows.Count: lrs = r + lr - 1
      Pages = sh.HPageBreaks.Count
     
      For iPage = 1 To Pages
        Set Page = sh.HPageBreaks(iPage)
        Set lcCell = Page.Location:  lcr = lcCell.Row
        If Not Intersect(area, lcCell) Is Nothing Then
          Set cell = sh.Cells(r, area.Column).Resize(lr, area.Columns.Count)
          If Not Intersect(cell, lcCell) Is Nothing Then
            If lcr > r And lcr <= lrs Then
              Set Page = sh.HPageBreaks(iPage)
              Set tRow = Page.Location
              Page.Delete
              Set Page.Location = cell(lr + 1, 1)
              tZoom = sh.PageSetup.Zoom
              If tZoom < limitPageMinZoom Then
                sh.PageSetup.Zoom = defaultPageZoom
                Page.Delete
                Set Page.Location = cell
              Else
                If sh.HPageBreaks.Count > Pages Then
                  Select Case sh.HPageBreaks(iPage).Type
                  Case xlPageBreakNone:
                  Case xlPageBreakAutomatic:  Set sh.HPageBreaks(iPage).Location = cell: Pages = sh.HPageBreaks.Count
                  Case xlPageBreakManual:
                  End Select
                Else
                  Pages = sh.HPageBreaks.Count
                End If
              End If
            End If
          End If
        End If
      Next
    Next
  Next
  FITPageBreaks = True
e:
 sh.DisplayPageBreaks = False
End Function
 
Lần chỉnh sửa cuối:
Upvote 0
vova2209 đã viết:
Chỉnh lại giúp em những dòng ở mục nội dung có công thức trả về không hoặc "" là đang bị unhide dòng lên ạ
Nhấp chuột vào đây để mở rộng...
File mẫu của bạn có dòng không có dữ liệu do đặt công thức, có dòng thì rỗng thiệt. Bạn xem lại có phải như vậy không, hay là dòng nào cũng chứa công thức?
 
Upvote 0
Maika8008 đã viết:
Sửa logic giải thuật lại 1 chút:
Rich (BB code): 
Sub FitTableContent()
    Dim ws As Worksheet
    Dim Rng As Range
    Dim h As Double
    Dim pb As HPageBreak
    Dim FRw&, LRw&, i&, Rw&, EndRw&
   
    Set ws = ActiveSheet
   
    FRw = 12
    If Cells.Find(What:="5.", LookIn:=xlFormulas, LookAt:=xlPart) Is Nothing Then
        MsgBox "Không tim thây chuoi '5.'": Exit Sub
    Else
        LRw = Cells.Find(What:="5.", LookIn:=xlFormulas, LookAt:=xlPart).Row - 1
    End If
   
    For i = FRw To LRw
        If Len(ws.Range("B" & i)) > 0 Then
            If Len(ws.Range("B" & i)) < 105 Then
                If Rng Is Nothing Then
                    Set Rng = ws.Range("B" & i).EntireRow
                Else
                    Set Rng = Union(Rng, ws.Range("B" & i).EntireRow)
                End If
            End If
        End If
    Next
   
    h = 18
    Rng.RowHeight = h
    Rw = ws.Range("B" & LRw + 1).End(xlUp).Row - 1
    EndRw = LRw + 10
   
    On Error Resume Next
    Set pb = ws.HPageBreaks(ws.HPageBreaks.Count)
   
    If pb Is Nothing Then GoTo End_
   
    If EndRw >= pb.Location.Row Then
        If pb.Location.Row > Rw Then
            Do Until pb.Location.Row <= Rw And h < 34
                h = h + 1
                Rng.RowHeight = h
            Loop
        End If
    End If

End_:
End Sub
Nhấp chuột vào đây để mở rộng...
em thêm đoạn code này vào để bỏ qua dòng đã ẩn đi rồi thì bị dãn dòng ra vô hạn: If ws.Rows(i).Hidden = False Then
Bài đã được tự động gộp:

Maika8008 đã viết:
File mẫu của bạn có dòng không có dữ liệu do đặt công thức, có dòng thì rỗng thiệt. Bạn xem lại có phải như vậy không, hay là dòng nào cũng chứa công thức?
Nhấp chuột vào đây để mở rộng...
dòng nào cũng có công thức ạ. Em đặt (" " & công thức) chỗ này " " là để tab thụt đầu dòng
 
Upvote 0
vova2209 đã viết:
dòng nào cũng có công thức ạ. Em đặt (" " & công thức) chỗ này " " là để tab thụt đầu dòng
Nhấp chuột vào đây để mở rộng...
Sửa lại code, điều kiện là công thức luôn luôn có 5 khoảng trắng như vậy:

Rich (BB code): 
Sub FitTableContent()
    Dim ws As Worksheet
    Dim Rng As Range
    Dim h As Double
    Dim pb As HPageBreak
    Dim FRw&, LRw&, i&, Rw&, EndRw&
    
    Set ws = ActiveSheet
    
    FRw = 12
    If Cells.Find(What:="5.", LookIn:=xlFormulas, LookAt:=xlPart) Is Nothing Then
        MsgBox "Không tim thây chuoi '5.'": Exit Sub
    Else
        LRw = Cells.Find(What:="5.", LookIn:=xlFormulas, LookAt:=xlPart).Row - 1
    End If
    
    For i = FRw To LRw
        If Len(ws.Range("B" & i)) > 0 Then
            If Len(ws.Range("B" & i)) < 105 And Len(ws.Range("B" & i)) > 5 Then
                If Rng Is Nothing Then
                    Set Rng = ws.Range("B" & i).EntireRow
                Else
                    Set Rng = Union(Rng, ws.Range("B" & i).EntireRow)
                End If
            End If
        End If
    Next
    
    h = 18
    Rng.RowHeight = h
    
    For i = LRw To FRw Step -1
        If Len(ws.Range("B" & i)) > 5 Then
            Rw = i - 1: Exit For
        End If
    Next
    
    EndRw = LRw + 10
    
    On Error Resume Next
    Set pb = ws.HPageBreaks(ws.HPageBreaks.Count)
    
    If pb Is Nothing Then GoTo End_
    
    If EndRw >= pb.Location.Row Then
        If pb.Location.Row > Rw Then
            Do Until pb.Location.Row <= Rw And h < 34
                h = h + 1
                Rng.RowHeight = h
            Loop
        End If
    End If

End_:
End Sub
 
Upvote 0
Maika8008 đã viết:
Sửa lại code, điều kiện là công thức luôn luôn có 5 khoảng trắng như vậy:

Rich (BB code): 
Sub FitTableContent()
    Dim ws As Worksheet
    Dim Rng As Range
    Dim h As Double
    Dim pb As HPageBreak
    Dim FRw&, LRw&, i&, Rw&, EndRw&
   
    Set ws = ActiveSheet
   
    FRw = 12
    If Cells.Find(What:="5.", LookIn:=xlFormulas, LookAt:=xlPart) Is Nothing Then
        MsgBox "Không tim thây chuoi '5.'": Exit Sub
    Else
        LRw = Cells.Find(What:="5.", LookIn:=xlFormulas, LookAt:=xlPart).Row - 1
    End If
   
    For i = FRw To LRw
        If Len(ws.Range("B" & i)) > 0 Then
            If Len(ws.Range("B" & i)) < 105 And Len(ws.Range("B" & i)) > 5 Then
                If Rng Is Nothing Then
                    Set Rng = ws.Range("B" & i).EntireRow
                Else
                    Set Rng = Union(Rng, ws.Range("B" & i).EntireRow)
                End If
            End If
        End If
    Next
   
    h = 18
    Rng.RowHeight = h
   
    For i = LRw To FRw Step -1
        If Len(ws.Range("B" & i)) > 5 Then
            Rw = i - 1: Exit For
        End If
    Next
   
    EndRw = LRw + 10
   
    On Error Resume Next
    Set pb = ws.HPageBreaks(ws.HPageBreaks.Count)
   
    If pb Is Nothing Then GoTo End_
   
    If EndRw >= pb.Location.Row Then
        If pb.Location.Row > Rw Then
            Do Until pb.Location.Row <= Rw And h < 34
                h = h + 1
                Rng.RowHeight = h
            Loop
        End If
    End If

End_:
End Sub
Nhấp chuột vào đây để mở rộng...
Anh xem giúp lại hộ em, em chạy code thì bị dãn ra vô hạn mãi không dừng
 

File đính kèm

Upvote 0
vova2209 đã viết:
Anh xem giúp lại hộ em, em chạy code thì bị dãn ra vô hạn mãi không dừng
Nhấp chuột vào đây để mở rộng...
Mẫu công việc của bạn vô chừng quá nên khó xử lý. Code này mà không được nữa thì thôi nha.
Rich (BB code): 
Sub FitTableContent2()
    Dim ws As Worksheet
    Dim Rng As Range
    Dim h As Double
    Dim pb As HPageBreak
    Dim FRw&, LRw&, i&, Rw&, EndRw&
    
    Set ws = ActiveSheet
    
    FRw = 12
    If Cells.Find(What:="giám sát", LookIn:=xlFormulas, LookAt:=xlPart) Is Nothing Then
        MsgBox "Không tim thây chuoi 'giám sát'": Exit Sub
    Else
        LRw = Cells.Find(What:="giám sát", LookIn:=xlFormulas, LookAt:=xlPart).Row - 3
    End If
    
    For i = FRw To LRw
        If Len(ws.Range("B" & i)) > 0 Then
            If Len(ws.Range("B" & i)) < 105 And Len(ws.Range("B" & i)) > 5 Then
                If Rng Is Nothing Then
                    Set Rng = ws.Range("B" & i).EntireRow
                Else
                    Set Rng = Union(Rng, ws.Range("B" & i).EntireRow)
                End If
            End If
        End If
    Next
    
    h = 18
    Rng.RowHeight = h
    
    For i = LRw To FRw Step -1
        If Len(ws.Range("B" & i)) > 5 Then
            Rw = i - 1: Exit For
        End If
    Next
    
    EndRw = Cells.Find(What:="giám sát", After:=Range("B1"), LookIn:=xlFormulas, LookAt:=xlPart).Row + 7
    
    On Error Resume Next
    Set pb = ws.HPageBreaks(ws.HPageBreaks.Count)
    On Error GoTo 0
    
    If pb Is Nothing Then GoTo End_
    
    If EndRw >= pb.Location.Row Then
        If pb.Location.Row > Rw Then
            Do Until pb.Location.Row <= Rw
                If h < 40 Then
                    h = h + 1
                    Rng.RowHeight = h
                Else
                    GoTo ActionX
                End If
            Loop
        End If
    End If
    
    Exit Sub
    
ActionX:
    For i = FRw To LRw
        If Len(ws.Range("B" & i)) > 0 Then
            If Len(ws.Range("B" & i)) >= 105 Then
                Set Rng = Union(Rng, ws.Range("B" & i).EntireRow)
            End If
        End If
    Next
    If EndRw >= pb.Location.Row Then
        If pb.Location.Row > Rw Then
            Do Until pb.Location.Row <= Rw
                If h < 50 Then
                    h = h + 1
                    Rng.RowHeight = h
                End If
            Loop
        End If
    End If
End_:
End Sub
 
Upvote 0
Maika8008 đã viết:
Mẫu công việc của bạn vô chừng quá nên khó xử lý. Code này mà không được nữa thì thôi nha.
Rich (BB code): 
Sub FitTableContent2()
    Dim ws As Worksheet
    Dim Rng As Range
    Dim h As Double
    Dim pb As HPageBreak
    Dim FRw&, LRw&, i&, Rw&, EndRw&
   
    Set ws = ActiveSheet
   
    FRw = 12
    If Cells.Find(What:="giám sát", LookIn:=xlFormulas, LookAt:=xlPart) Is Nothing Then
        MsgBox "Không tim thây chuoi 'giám sát'": Exit Sub
    Else
        LRw = Cells.Find(What:="giám sát", LookIn:=xlFormulas, LookAt:=xlPart).Row - 3
    End If
   
    For i = FRw To LRw
        If Len(ws.Range("B" & i)) > 0 Then
            If Len(ws.Range("B" & i)) < 105 And Len(ws.Range("B" & i)) > 5 Then
                If Rng Is Nothing Then
                    Set Rng = ws.Range("B" & i).EntireRow
                Else
                    Set Rng = Union(Rng, ws.Range("B" & i).EntireRow)
                End If
            End If
        End If
    Next
   
    h = 18
    Rng.RowHeight = h
   
    For i = LRw To FRw Step -1
        If Len(ws.Range("B" & i)) > 5 Then
            Rw = i - 1: Exit For
        End If
    Next
   
    EndRw = Cells.Find(What:="giám sát", After:=Range("B1"), LookIn:=xlFormulas, LookAt:=xlPart).Row + 7
   
    On Error Resume Next
    Set pb = ws.HPageBreaks(ws.HPageBreaks.Count)
    On Error GoTo 0
   
    If pb Is Nothing Then GoTo End_
   
    If EndRw >= pb.Location.Row Then
        If pb.Location.Row > Rw Then
            Do Until pb.Location.Row <= Rw
                If h < 40 Then
                    h = h + 1
                    Rng.RowHeight = h
                Else
                    GoTo ActionX
                End If
            Loop
        End If
    End If
   
    Exit Sub
   
ActionX:
    For i = FRw To LRw
        If Len(ws.Range("B" & i)) > 0 Then
            If Len(ws.Range("B" & i)) >= 105 Then
                Set Rng = Union(Rng, ws.Range("B" & i).EntireRow)
            End If
        End If
    Next
    If EndRw >= pb.Location.Row Then
        If pb.Location.Row > Rw Then
            Do Until pb.Location.Row <= Rw
                If h < 50 Then
                    h = h + 1
                    Rng.RowHeight = h
                End If
            Loop
        End If
    End If
End_:
End Sub
Nhấp chuột vào đây để mở rộng...
Chạy tốt rồi ạ, em cảm ơn Anh nhiều. Chúc Anh 1 ngày vui vẻ
 
Upvote 0
Maika8008 đã viết:
Mẫu công việc của bạn vô chừng quá nên khó xử lý. Code này mà không được nữa thì thôi nha.
Rich (BB code): 
Sub FitTableContent2()
    Dim ws As Worksheet
    Dim Rng As Range
    Dim h As Double
    Dim pb As HPageBreak
    Dim FRw&, LRw&, i&, Rw&, EndRw&
   
    Set ws = ActiveSheet
   
    FRw = 12
    If Cells.Find(What:="giám sát", LookIn:=xlFormulas, LookAt:=xlPart) Is Nothing Then
        MsgBox "Không tim thây chuoi 'giám sát'": Exit Sub
    Else
        LRw = Cells.Find(What:="giám sát", LookIn:=xlFormulas, LookAt:=xlPart).Row - 3
    End If
   
    For i = FRw To LRw
        If Len(ws.Range("B" & i)) > 0 Then
            If Len(ws.Range("B" & i)) < 105 And Len(ws.Range("B" & i)) > 5 Then
                If Rng Is Nothing Then
                    Set Rng = ws.Range("B" & i).EntireRow
                Else
                    Set Rng = Union(Rng, ws.Range("B" & i).EntireRow)
                End If
            End If
        End If
    Next
   
    h = 18
    Rng.RowHeight = h
   
    For i = LRw To FRw Step -1
        If Len(ws.Range("B" & i)) > 5 Then
            Rw = i - 1: Exit For
        End If
    Next
   
    EndRw = Cells.Find(What:="giám sát", After:=Range("B1"), LookIn:=xlFormulas, LookAt:=xlPart).Row + 7
   
    On Error Resume Next
    Set pb = ws.HPageBreaks(ws.HPageBreaks.Count)
    On Error GoTo 0
   
    If pb Is Nothing Then GoTo End_
   
    If EndRw >= pb.Location.Row Then
        If pb.Location.Row > Rw Then
            Do Until pb.Location.Row <= Rw
                If h < 40 Then
                    h = h + 1
                    Rng.RowHeight = h
                Else
                    GoTo ActionX
                End If
            Loop
        End If
    End If
   
    Exit Sub
   
ActionX:
    For i = FRw To LRw
        If Len(ws.Range("B" & i)) > 0 Then
            If Len(ws.Range("B" & i)) >= 105 Then
                Set Rng = Union(Rng, ws.Range("B" & i).EntireRow)
            End If
        End If
    Next
    If EndRw >= pb.Location.Row Then
        If pb.Location.Row > Rw Then
            Do Until pb.Location.Row <= Rw
                If h < 50 Then
                    h = h + 1
                    Rng.RowHeight = h
                End If
            Loop
        End If
    End If
End_:
End Sub
Nhấp chuột vào đây để mở rộng...
Chỉ cần sang trang mới 1 dòng thôi thì sửa chỗ nào Anh nhỉ
 
Upvote 0
Bạn đã thử code bài #12 chưa
Chỉ cần bạn chọn vùng cần in và Đặt thành vùng in là Print Area, chuyển sang chế độ xem trước ngắt trang

1773313321971.png

Nút chuyển thứ 3 thành chế độ xem trước ngắt trang

Và chạy mã sau khi bạn giãn dòng tự động, [B71:E80] chính là vùng luôn cần xét đặt trong trang, có thể đặt thành Name để không phải mất thời gian sửa đổi
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

Bài viết mới nhất

vova2209
  • Question Question
Co, Dãn dòng vừa trang in (2 người xem)
Trả lời
20
Đọc
381
Maika8008
Maika8008
N
Lập file Nhập - Xuất - Tồn cho kho có 300 mã nguyên vật liệu
Trả lời
0
Đọc
40
nguyenlamthumua
N
G
Vẽ mặt cắt dầm từ excel
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
21
Đọc
2K
gpe.vn
G
E
Xin giúp tách lấy tên Tỉnh thành, Quận huyện, Phường xã từ địa chỉ có sẵn
Trả lời
9
Đọc
2K
HUONGHCKT
H
phuongnam366377
Xây dựng RPC Server cho Excel / Access bằng Delphi – Tận dụng lại DLL và bảo mật mã nguồn
    • Thích
Trả lời
10
Đọc
353
A-T
A
V
các bác ơi giúp e hàm countif với ạ (1 người xem)
    • Thích
Trả lời
3
Đọc
107
vunl
V
H
Làm phiếu lương nhân viên công ty
    • Cười
Trả lời
3
Đọc
161
trhieu
T
N
Lập báo cáo thống kê sản lượng theo ngày của từng nhân viên
Trả lời
4
Đọc
83
levant0908
L
T
Xin đoạn code để gửi mail hàng loạt có đính kèm file PDF (1 người xem)
Trả lời
3
Đọc
225
levant0908
L
H
Xin A/C Giúp Tách địa chỉ ra Tỉnh , Huyện, Xã, Ấp
Trả lời
11
Đọc
2K
dong.nguyen.hdkt
D
katanvn
File kiểm đếm phiếu bầu cử 2026-2031 dễ hiểu có kết quả và biên bản (6 người xem)
    • Thích
Trả lời
7
Đọc
5K
katanvn
katanvn
GPE-Trợ Lý
[GPE22] BƯỚC NÂNG CẤP QUAN TRỌNG NHỮNG POWER QUERY ĐƠN GIẢN (1 người xem)
    • Thích
Trả lời
0
Đọc
502
GPE-Trợ Lý
GPE-Trợ Lý
SA_DQ
Copilot bình luận các ván cờ vua từng ngày. (1 người xem)
    • Thích
Trả lời
93
Đọc
3K
SA_DQ
SA_DQ
phuongnam366377
  • Question Question
Vì sao KHÔNG nên sử dụng Excel (VBA) làm máy chủ
Trả lời
4
Đọc
212
phuongnam366377
phuongnam366377
Nguyễn Duy Tuân
  • Dán lên cao
Phiên bản mới Add-in A-Tools AI v10 (2024)
    • Thích
Trả lời
68
Đọc
13K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
adua29
File Excel kiểm phiếu bầu cử Quốc hội và HĐND các cấp
    • Thích
Trả lời
27
Đọc
7K
cameravp2022
C
V
Biểu diễn số đếm theo hình vẽ từ Shape
Trả lời
38
Đọc
1K
HUONGHCKT
H
V
Một Excel add-in vibe coding
    • Thích
Trả lời
26
Đọc
1K
vietdang170
V
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
5 6 7
Trả lời
641
Đọc
96K
pycckuu410
pycckuu410
adua29
Gửi tặng file excel kiểm phiếu bầu cử Đại biểu Quốc hội và Hội đồng nhân dân các cấp
    • Thích
    • Yêu thích
Trả lời
26
Đọc
30K
adua29
adua29
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom