Tự động căn dòng trang in có điều kiện

Liên hệ QC
T

ThaiDieuAnh

Thành viên hoạt động
Tham gia
8/8/16
Bài viết
139
Được thích
24
Nghề nghiệp
Xây dựng
Em có 1 sheet biên bản nghiệm thu, dữ liệu trong sheet luôn thay đổi (có lúc thêm hoặc bớt hàng hoặc kích thước hàng tăng, giảm) nên trang in có thể bị nhảy thêm hoặc bớt. Em muốn tự động "breaks page" để đảm bảo chỗ ký tên luôn ổn định khi in. Mong các anh chị giúp, em xin cảm ơn!
 

File đính kèm

  • Ngat trang co dieu kien.xlsx
    20.1 KB · Đọc: 24
Sắp xếp theo thời gian sắp xếp theo bầu chọn
ThaiDieuAnh đã viết:
Em có 1 sheet biên bản nghiệm thu, dữ liệu trong sheet luôn thay đổi (có lúc thêm hoặc bớt hàng hoặc kích thước hàng tăng, giảm) nên trang in có thể bị nhảy thêm hoặc bớt. Em muốn tự động "breaks page" để đảm bảo chỗ ký tên luôn ổn định khi in. Mong các anh chị giúp, em xin cảm ơn!
Nhấp chuột vào đây để mở rộng...
Bạn thử cái này xem. Nhưng nó chậm lắm (Do sơ xuất đínhkèm lại file)
 

File đính kèm

  • Ngat trang co dieu kien.xlsm
    31.9 KB · Đọc: 23
Lần chỉnh sửa cuối:
Upvote 0
Cảm ơn bác PacificPR, nhưng cách của bác chưa đáp ứng với yêu cầu của em ạ. Ý em muốn là khi xóa hoặc ẩn một số hàng thì vẫn giữ nguyên chiều rộng của các hàng còn lại và không unhide các hàng đã ẩn. Code sẽ tự động breaks page lại để luôn đảm bảo nếu tràn trang thì phần ký biên bản sẽ không bị tách ra mà chuyển sang trang mới
 

File đính kèm

  • Ngat trang co dieu kien.xlsm
    41.6 KB · Đọc: 7
Upvote 0
Ai bẩu bạn đưa file ví dụ không có dòng ẩn. Nhưng tốc độ nó chậm đấy
 
Upvote 0
ThaiDieuAnh đã viết:
Cảm ơn bác PacificPR, nhưng cách của bác chưa đáp ứng với yêu cầu của em ạ. Ý em muốn là khi xóa hoặc ẩn một số hàng thì vẫn giữ nguyên chiều rộng của các hàng còn lại và không unhide các hàng đã ẩn. Code sẽ tự động breaks page lại để luôn đảm bảo nếu tràn trang thì phần ký biên bản sẽ không bị tách ra mà chuyển sang trang mới
Nhấp chuột vào đây để mở rộng...
Bạn tải nhầm file rồi. Tải lại File bài 2 đi bạn à
Còn cái vụ không cho hiện dòng ẩn thì thêm 1 bước For nữa là được
PHP: 
Sub AddBreaks()
    Dim Ws As Worksheet, fRowNumber As Long, EfRowNumber As Long, NumberRow As Long, I As Long
    Dim DeltaRowHei As Double, fCurr As Long, fP As Long
Application.ScreenUpdating = False
Set Ws = ActiveSheet
fRowNumber = Ws.Range("AB1"): EfRowNumber = Ws.Range("AB2")
For I = fRowNumber To EfRowNumber
    If Ws.Range("C" & I).EntireRow.Hidden = False Then _
            Ws.Range("C" & I).EntireRow.AutoFit
    If Range("B" & I) <> Empty Then FixRow Range("C" & I & ":AA" & I)
Next I
ActiveWindow.View = xlPageBreakPreview
fP = Ws.HPageBreaks.Count
fCurr = ActiveSheet.HPageBreaks(fP).Location.row
NumberRow = EfRowNumber - fRowNumber
If fCurr > EfRowNumber Then
    DeltaRowHei = Ws.Range("E" & EfRowNumber & ":E" & fCurr).Height / NumberRow
    For I = fRowNumber To EfRowNumber
        If Ws.Range("C" & I).EntireRow.Hidden = False Then _
                Ws.Range("C" & I).RowHeight = Ws.Range("C" & I).RowHeight + DeltaRowHei + 16.5 / 5
    Next I
End If
ActiveWindow.View = xlNormalView
Application.ScreenUpdating = True
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Bạn thử file. Mình thấy ổn nhưng tốc độ hơi chậm. Hôm trước xem File bên Giá xây dựng họ có làm cái này nhưng họ khóa ác quá nên chẳng ăn trộm được cái gì :p
 

File đính kèm

  • Ngat trang co dieu kien (1) (1).xlsm
    33.4 KB · Đọc: 45
Upvote 0
PacificPR đã viết:
Bạn thử file. Mình thấy ổn nhưng tốc độ hơi chậm. Hôm trước xem File bên Giá xây dựng họ có làm cái này nhưng họ khóa ác quá nên chẳng ăn trộm được cái gì :p
Nhấp chuột vào đây để mở rộng...
Cảm ơn bác, em thấy cũng ổn rồi bác ạ. Tốc độ hơi chậm nhưng nó làm được 2 việc là Fix row và Breaks page. Làm cái QLCL này cũng khó cầu toàn lắm bác ạ, mỗi nơi 1 kiểu. Rõ ràng không thể lường hết các trường hợp xảy ra.
 
Upvote 0
PacificPR đã viết:
Bạn thử file. Mình thấy ổn nhưng tốc độ hơi chậm. Hôm trước xem File bên Giá xây dựng họ có làm cái này nhưng họ khóa ác quá nên chẳng ăn trộm được cái gì :p
Nhấp chuột vào đây để mở rộng...
dạo này không onl vào diễn đàn thấy code cũng kinh nhể, gọn gàng gớm, không lườm thườm như "cha" kia.:)
thế là có cái học hỏi rồi. --=0
 
Upvote 0
PacificPR đã viết:
Bạn tải nhầm file rồi. Tải lại File bài 2 đi bạn à
Còn cái vụ không cho hiện dòng ẩn thì thêm 1 bước For nữa là được
PHP: 
Sub AddBreaks()
    Dim Ws As Worksheet, fRowNumber As Long, EfRowNumber As Long, NumberRow As Long, I As Long
    Dim DeltaRowHei As Double, fCurr As Long, fP As Long
Application.ScreenUpdating = False
Set Ws = ActiveSheet
fRowNumber = Ws.Range("AB1"): EfRowNumber = Ws.Range("AB2")
For I = fRowNumber To EfRowNumber
    If Ws.Range("C" & I).EntireRow.Hidden = False Then _
            Ws.Range("C" & I).EntireRow.AutoFit
    If Range("B" & I) <> Empty Then FixRow Range("C" & I & ":AA" & I)
Next I
ActiveWindow.View = xlPageBreakPreview
fP = Ws.HPageBreaks.Count
fCurr = ActiveSheet.HPageBreaks(fP).Location.row
NumberRow = EfRowNumber - fRowNumber
If fCurr > EfRowNumber Then
    DeltaRowHei = Ws.Range("E" & EfRowNumber & ":E" & fCurr).Height / NumberRow
    For I = fRowNumber To EfRowNumber
        If Ws.Range("C" & I).EntireRow.Hidden = False Then _
                Ws.Range("C" & I).RowHeight = Ws.Range("C" & I).RowHeight + DeltaRowHei + 16.5 / 5
    Next I
End If
ActiveWindow.View = xlNormalView
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
góp ý thêm cái, theo như xem code của bạn thì có 1 số chỗ thế này
máy mình dùng ổ SSD nên không test được tốc độ khi so với máy dùng ổ HDD được.
theo như bạn nói tốc độ chậm thì mình xem code chỉ chỉnh những dòng có đánh dấu "x" tại cột B thì chỉ có làm việc với 7 dòng mà tốc độ chậm thì nên xem lại.
còn vài chỗ này
liệu muôn thuở nó luôn là 1 dòng không.
Dự án: Dự án 1
Tiểu dự án: Tiểu dự án 1
Gói thầu: Gói thầu 1
Công trình: Công trình 1
Địa điểm xây dựng: Cầu giấy
nếu thêm dấu x tại các dòng đó thì tốc độ sẽ thế nào nữa
 
Upvote 0
Mutants Men đã viết:
góp ý thêm cái, theo như xem code của bạn thì có 1 số chỗ thế này
máy mình dùng ổ SSD nên không test được tốc độ khi so với máy dùng ổ HDD được.
theo như bạn nói tốc độ chậm thì mình xem code chỉ chỉnh những dòng có đánh dấu "x" tại cột B thì chỉ có làm việc với 7 dòng mà tốc độ chậm thì nên xem lại.
còn vài chỗ này
liệu muôn thuở nó luôn là 1 dòng không.
Dự án: Dự án 1
Tiểu dự án: Tiểu dự án 1
Gói thầu: Gói thầu 1
Công trình: Công trình 1
Địa điểm xây dựng: Cầu giấy
nếu thêm dấu x tại các dòng đó thì tốc độ sẽ thế nào nữa
Nhấp chuột vào đây để mở rộng...
Hình Nó chậm chắc là 2 cái dòng For và nhảy tới nhảy lui thì phải anh ạ
 
Upvote 0
PacificPR đã viết:
Hình Nó chậm chắc là 2 cái dòng For và nhảy tới nhảy lui thì phải anh ạ
Nhấp chuột vào đây để mở rộng...
Em xin phép up lại file của anh PacificPR lên mong các anh chị trên GPE sửa lại code để chạy mượt hơn giúp em ạ.
Bài toán là: Khi Click Button các hàng tại cột B chứa dữ liệu X có thể thay đổi => Code có 2 nhiệm vụ là Fix row những ô đã Marge và Breaks page để khi in ấn thành phần ký luôn nằm sát nhau (có thể 1 trang hoặc 2 trang). Code trong File đính kèm đã làm được 2 nhiệm vụ trên nhưng khi dữ liệu biên bản nhiều thì chạy tương đối chậm. Lý do có thể như
Hình Nó chậm chắc là 2 cái dòng For và nhảy tới nhảy lui thì phải anh ạ
Nhấp chuột vào đây để mở rộng...
Mong các anh chị giúp đỡ, em xin cảm ơn!
 

File đính kèm

  • Ngat trang co dieu kien .xlsm
    29.4 KB · Đọc: 14
Upvote 0
Thì cứ cho nó tạo ngắt trang tự động đi, rồi kiểm tra xem có cái ngắt trang nào nằm ở vùng ở giữa cái vùng ký tên không, nếu có thì thêm một ngắt trang cứng vào đầu phần ký tên.
 
Upvote 0
PacificPR đã viết:
Hình Nó chậm chắc là 2 cái dòng For và nhảy tới nhảy lui thì phải anh ạ
Nhấp chuột vào đây để mở rộng...
Chậm do thao tác trên Range quá nhiều lần
Dùng mảng giảm phần nào thao tác trên range
Mã: 
Sub AutoFitRowHeight()
  Dim fRow As Long, lRow As Long, NumberRow As Long
  Dim i As Long, ik As Long
  Dim DeltaRowHei As Double, fCurr As Long, fP As Long
  Dim m As Double, tmp As Double, MrgeWdth As Double
  Dim col As Byte, Scol As Byte, j As Byte, n As Byte, k As Byte
  Dim Arr As Variant
Application.ScreenUpdating = False
i = Range("B65000").End(xlUp).row
If i < 7 Then Exit Sub 'Khong co dong fit
Arr = Range("B1:B" & i).Value
For i = 7 To UBound(Arr)
  If UCase(Arr(i, 1)) = "X" Then
    lRow = i
    If fRow = 0 Then fRow = i
  End If
Next i
If lRow = 0 Then Exit Sub 'Khong co dong fit
ReDim Arr(1 To lRow - fRow + 2, 1 To 10)
With CreateObject("scripting.dictionary")
  For i = fRow To lRow
    If Range("B" & i).EntireRow.Hidden = False And Range("B" & i) <> Empty Then
      n = 0
      For col = 3 To 27
        If Cells(i, col) <> Empty And Cells(i, col).MergeCells Then
          Scol = Cells(i, col).MergeArea.Columns.Count
          MrgeWdth = 0
          For j = 1 To Scol
            MrgeWdth = MrgeWdth + Cells(i, col + j - 1).ColumnWidth + 0.75
          Next j
          If Not .exists(MrgeWdth) Then
            k = k + 1
            .Add MrgeWdth, k
            Arr(UBound(Arr), k) = MrgeWdth
          End If
          n = n + 1
          ik = i - fRow + 1
          Arr(ik, .Item(MrgeWdth)) = Cells(i, col).Value
          Cells(i, 29 + n).Font.Size = Cells(i, col).Font.Size
          If Cells(i, col).Font.Bold = True Then Cells(i, 29 + n).Font.Bold = True
          If Cells(i, col).Font.Italic = True Then Cells(i, 29 + n).Font.Italic = True
          If Cells(i, col).Font.Underline = xlUnderlineStyleSingle Then Cells(i, 29 + n).Font.Underline = xlUnderlineStyleSingle
          col = col + Scol - 1
        End If
      Next col
    End If
  Next i
End With
Range("AD" & fRow).Resize(UBound(Arr) - 1, k) = Arr
Range("AD" & fRow).Resize(UBound(Arr) - 1, k).WrapText = True
For j = 1 To k
  Cells(1, 29 + j).ColumnWidth = Arr(UBound(Arr), j)
Next j
For i = 1 To UBound(Arr) - 1
  m = 0
  For j = 1 To k
    If Arr(i, j) <> Empty Then
        Cells(fRow + i - 1, 29 + j).EntireRow.AutoFit
        tmp = Cells(fRow + i - 1, 29 + j).RowHeight
        If m < tmp Then m = tmp
    End If
  Next j
  If m Then Cells(fRow + i - 1, 3).RowHeight = m
Next i
Range("AD" & fRow).Resize(UBound(Arr) - 1, k).Clear
'****
ActiveWindow.View = xlPageBreakPreview
fP = ActiveSheet.HPageBreaks.Count
fCurr = ActiveSheet.HPageBreaks(fP).Location.row
NumberRow = lRow - fRow
If fCurr > lRow Then
    DeltaRowHei = Range("E" & lRow & ":E" & fCurr).Height / NumberRow
    For i = fRow To lRow
        If Range("C" & i).EntireRow.Hidden = False Then _
                Range("C" & i).RowHeight = Range("C" & i).RowHeight + DeltaRowHei + 16.5 / 5
    Next i
End If
ActiveWindow.View = xlNormalView
Application.ScreenUpdating = True
End Sub
 

File đính kèm

  • Ngat trang co dieu kien .xlsm
    29.9 KB · Đọc: 49
Upvote 0
HieuCD đã viết:
Chậm do thao tác trên Range quá nhiều lần
Dùng mảng giảm phần nào thao tác trên range
Mã: 
Sub AutoFitRowHeight()
  Dim fRow As Long, lRow As Long, NumberRow As Long
  Dim i As Long, ik As Long
  Dim DeltaRowHei As Double, fCurr As Long, fP As Long
  Dim m As Double, tmp As Double, MrgeWdth As Double
  Dim col As Byte, Scol As Byte, j As Byte, n As Byte, k As Byte
  Dim Arr As Variant
Application.ScreenUpdating = False
i = Range("B65000").End(xlUp).row
If i < 7 Then Exit Sub 'Khong co dong fit
Arr = Range("B1:B" & i).Value
For i = 7 To UBound(Arr)
  If UCase(Arr(i, 1)) = "X" Then
    lRow = i
    If fRow = 0 Then fRow = i
  End If
Next i
If lRow = 0 Then Exit Sub 'Khong co dong fit
ReDim Arr(1 To lRow - fRow + 2, 1 To 10)
With CreateObject("scripting.dictionary")
  For i = fRow To lRow
    If Range("B" & i).EntireRow.Hidden = False And Range("B" & i) <> Empty Then
      n = 0
      For col = 3 To 27
        If Cells(i, col) <> Empty And Cells(i, col).MergeCells Then
          Scol = Cells(i, col).MergeArea.Columns.Count
          MrgeWdth = 0
          For j = 1 To Scol
            MrgeWdth = MrgeWdth + Cells(i, col + j - 1).ColumnWidth + 0.75
          Next j
          If Not .exists(MrgeWdth) Then
            k = k + 1
            .Add MrgeWdth, k
            Arr(UBound(Arr), k) = MrgeWdth
          End If
          n = n + 1
          ik = i - fRow + 1
          Arr(ik, .Item(MrgeWdth)) = Cells(i, col).Value
          Cells(i, 29 + n).Font.Size = Cells(i, col).Font.Size
          If Cells(i, col).Font.Bold = True Then Cells(i, 29 + n).Font.Bold = True
          If Cells(i, col).Font.Italic = True Then Cells(i, 29 + n).Font.Italic = True
          If Cells(i, col).Font.Underline = xlUnderlineStyleSingle Then Cells(i, 29 + n).Font.Underline = xlUnderlineStyleSingle
          col = col + Scol - 1
        End If
      Next col
    End If
  Next i
End With
Range("AD" & fRow).Resize(UBound(Arr) - 1, k) = Arr
Range("AD" & fRow).Resize(UBound(Arr) - 1, k).WrapText = True
For j = 1 To k
  Cells(1, 29 + j).ColumnWidth = Arr(UBound(Arr), j)
Next j
For i = 1 To UBound(Arr) - 1
  m = 0
  For j = 1 To k
    If Arr(i, j) <> Empty Then
        Cells(fRow + i - 1, 29 + j).EntireRow.AutoFit
        tmp = Cells(fRow + i - 1, 29 + j).RowHeight
        If m < tmp Then m = tmp
    End If
  Next j
  If m Then Cells(fRow + i - 1, 3).RowHeight = m
Next i
Range("AD" & fRow).Resize(UBound(Arr) - 1, k).Clear
'****
ActiveWindow.View = xlPageBreakPreview
fP = ActiveSheet.HPageBreaks.Count
fCurr = ActiveSheet.HPageBreaks(fP).Location.row
NumberRow = lRow - fRow
If fCurr > lRow Then
    DeltaRowHei = Range("E" & lRow & ":E" & fCurr).Height / NumberRow
    For i = fRow To lRow
        If Range("C" & i).EntireRow.Hidden = False Then _
                Range("C" & i).RowHeight = Range("C" & i).RowHeight + DeltaRowHei + 16.5 / 5
    Next i
End If
ActiveWindow.View = xlNormalView
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Code của anh HieuCD cải thiện tốc độ rõ rệt ạ, nhân tiện nhờ anh giúp em sửa lại chỗ: Nếu cột B có giá trị X thì mới fix row, ngược lại thì giữ nguyên ạ. Em xin cảm ơn
 
Upvote 0
HieuCD đã viết:
Chậm do thao tác trên Range quá nhiều lần
Dùng mảng giảm phần nào thao tác trên range
Mã: 
Sub AutoFitRowHeight()
  Dim fRow As Long, lRow As Long, NumberRow As Long
  Dim i As Long, ik As Long
  Dim DeltaRowHei As Double, fCurr As Long, fP As Long
  Dim m As Double, tmp As Double, MrgeWdth As Double
  Dim col As Byte, Scol As Byte, j As Byte, n As Byte, k As Byte
  Dim Arr As Variant
Application.ScreenUpdating = False
i = Range("B65000").End(xlUp).row
If i < 7 Then Exit Sub 'Khong co dong fit
Arr = Range("B1:B" & i).Value
For i = 7 To UBound(Arr)
  If UCase(Arr(i, 1)) = "X" Then
    lRow = i
    If fRow = 0 Then fRow = i
  End If
Next i
If lRow = 0 Then Exit Sub 'Khong co dong fit
ReDim Arr(1 To lRow - fRow + 2, 1 To 10)
With CreateObject("scripting.dictionary")
  For i = fRow To lRow
    If Range("B" & i).EntireRow.Hidden = False And Range("B" & i) <> Empty Then
      n = 0
      For col = 3 To 27
        If Cells(i, col) <> Empty And Cells(i, col).MergeCells Then
          Scol = Cells(i, col).MergeArea.Columns.Count
          MrgeWdth = 0
          For j = 1 To Scol
            MrgeWdth = MrgeWdth + Cells(i, col + j - 1).ColumnWidth + 0.75
          Next j
          If Not .exists(MrgeWdth) Then
            k = k + 1
            .Add MrgeWdth, k
            Arr(UBound(Arr), k) = MrgeWdth
          End If
          n = n + 1
          ik = i - fRow + 1
          Arr(ik, .Item(MrgeWdth)) = Cells(i, col).Value
          Cells(i, 29 + n).Font.Size = Cells(i, col).Font.Size
          If Cells(i, col).Font.Bold = True Then Cells(i, 29 + n).Font.Bold = True
          If Cells(i, col).Font.Italic = True Then Cells(i, 29 + n).Font.Italic = True
          If Cells(i, col).Font.Underline = xlUnderlineStyleSingle Then Cells(i, 29 + n).Font.Underline = xlUnderlineStyleSingle
          col = col + Scol - 1
        End If
      Next col
    End If
  Next i
End With
Range("AD" & fRow).Resize(UBound(Arr) - 1, k) = Arr
Range("AD" & fRow).Resize(UBound(Arr) - 1, k).WrapText = True
For j = 1 To k
  Cells(1, 29 + j).ColumnWidth = Arr(UBound(Arr), j)
Next j
For i = 1 To UBound(Arr) - 1
  m = 0
  For j = 1 To k
    If Arr(i, j) <> Empty Then
        Cells(fRow + i - 1, 29 + j).EntireRow.AutoFit
        tmp = Cells(fRow + i - 1, 29 + j).RowHeight
        If m < tmp Then m = tmp
    End If
  Next j
  If m Then Cells(fRow + i - 1, 3).RowHeight = m
Next i
Range("AD" & fRow).Resize(UBound(Arr) - 1, k).Clear
'****
ActiveWindow.View = xlPageBreakPreview
fP = ActiveSheet.HPageBreaks.Count
fCurr = ActiveSheet.HPageBreaks(fP).Location.row
NumberRow = lRow - fRow
If fCurr > lRow Then
    DeltaRowHei = Range("E" & lRow & ":E" & fCurr).Height / NumberRow
    For i = fRow To lRow
        If Range("C" & i).EntireRow.Hidden = False Then _
                Range("C" & i).RowHeight = Range("C" & i).RowHeight + DeltaRowHei + 16.5 / 5
    Next i
End If
ActiveWindow.View = xlNormalView
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Anh HieuCD xem giúp em mấy chỗ em bôi vàng được không ạ, bữa lâu giờ vẫn xài code anh trong công việc. Giờ mới thấy có 1 số chỗ nó không tự động fixrow anh ạ. Em xin cảm ơn!
 

File đính kèm

  • Ngat trang co dieu kien _ A Hieu CD.xlsm
    31.4 KB · Đọc: 38
Upvote 0
ThaiDieuAnh đã viết:
Anh HieuCD xem giúp em mấy chỗ em bôi vàng được không ạ, bữa lâu giờ vẫn xài code anh trong công việc. Giờ mới thấy có 1 số chỗ nó không tự động fixrow anh ạ. Em xin cảm ơn!
Nhấp chuột vào đây để mở rộng...
Chỉnh lại code
Mã: 
Sub AutoFitRowHeight()
  Dim fRow As Long, lRow As Long, NumberRow As Long
  Dim i As Long, jk As Long, k As Long
  Dim DeltaRowHei As Double, fCurr As Long, fP As Long
  Dim MrgeWdth As Double
  Dim col As Byte, Scol As Byte, j As Byte
  Dim Arr(), sArr()
  Dim tmp As String
Application.ScreenUpdating = False
i = Range("B65000").End(xlUp).Row
If i < 7 Then Exit Sub 'Khong co dong fit
sArr = Range("B1:B" & i).Value
For i = 7 To UBound(sArr)
  If UCase(sArr(i, 1)) = "X" And Range("B" & i).EntireRow.Hidden = False Then
    lRow = i
    If fRow = 0 Then fRow = i
  Else
    sArr(i, 1) = Null
  End If
Next i
If lRow = 0 Then Exit Sub 'Khong co dong fit
'Phan fix row

ReDim Arr(fRow To lRow, 1 To 20)
With CreateObject("scripting.dictionary")
  For i = fRow To lRow
    If Len(sArr(i, 1)) Then
      For col = 3 To 27
        If Cells(i, col) <> Empty And Cells(i, col).MergeCells Then
          Scol = Cells(i, col).MergeArea.Columns.Count
          MrgeWdth = 0
          tmp = Cells(i, col).Column & Cells(i, col + Scol - 1).Column
          For j = 1 To Scol
            MrgeWdth = MrgeWdth + Cells(i, col + j - 1).ColumnWidth + 0.75
          Next j
          If Not .exists(tmp) Then
            k = k + 1
            .Add tmp, k
            Cells(1, 29 + k).ColumnWidth = MrgeWdth
          End If
          jk = .Item(tmp)
          Arr(i, jk) = Cells(i, col).Value
          Cells(i, 29 + jk).Font.Size = Cells(i, col).Font.Size
          If Cells(i, col).Font.Bold = True Then Cells(i, 29 + jk).Font.Bold = True
          If Cells(i, col).Font.Italic = True Then Cells(i, 29 + jk).Font.Italic = True
          If Cells(i, col).Font.Underline = xlUnderlineStyleSingle Then Cells(i, 29 + jk).Font.Underline = xlUnderlineStyleSingle
          col = col + Scol - 1
        End If
      Next col
    End If
  Next i
End With
Range("AD" & fRow).Resize(UBound(Arr), k) = Arr
Range("AD" & fRow).Resize(UBound(Arr), k).WrapText = True

For i = fRow To lRow
    If Len(sArr(i, 1)) Then
      Rows(i).EntireRow.AutoFit
      Rows(i).RowHeight = Rows(i).RowHeight
    End If
Next i
Range("AD" & fRow).Resize(UBound(Arr), k).Clear
'Khong ro code duoi muc dich lam gi ???

On Error Resume Next
ActiveWindow.View = xlPageBreakPreview
fP = ActiveSheet.HPageBreaks.Count
fCurr = ActiveSheet.HPageBreaks(fP).Location.Row
NumberRow = lRow - fRow
If fCurr > lRow Then
    DeltaRowHei = Range("E" & lRow & ":E" & fCurr).Height / NumberRow
    For i = lRow To fRow Step -1
        If Range("C" & i).EntireRow.Hidden = False Then _
                Range("C" & i).RowHeight = Range("C" & i).RowHeight + DeltaRowHei + 16.5 / 5
    Next i
End If
ActiveWindow.View = xlNormalView
Application.ScreenUpdating = True
End Sub
 
Upvote 0
HieuCD đã viết:
Chỉnh lại code
Mã: 
Sub AutoFitRowHeight()
  Dim fRow As Long, lRow As Long, NumberRow As Long
  Dim i As Long, jk As Long, k As Long
  Dim DeltaRowHei As Double, fCurr As Long, fP As Long
  Dim MrgeWdth As Double
  Dim col As Byte, Scol As Byte, j As Byte
  Dim Arr(), sArr()
  Dim tmp As String
Application.ScreenUpdating = False
i = Range("B65000").End(xlUp).Row
If i < 7 Then Exit Sub 'Khong co dong fit
sArr = Range("B1:B" & i).Value
For i = 7 To UBound(sArr)
  If UCase(sArr(i, 1)) = "X" And Range("B" & i).EntireRow.Hidden = False Then
    lRow = i
    If fRow = 0 Then fRow = i
  Else
    sArr(i, 1) = Null
  End If
Next i
If lRow = 0 Then Exit Sub 'Khong co dong fit
'Phan fix row

ReDim Arr(fRow To lRow, 1 To 20)
With CreateObject("scripting.dictionary")
  For i = fRow To lRow
    If Len(sArr(i, 1)) Then
      For col = 3 To 27
        If Cells(i, col) <> Empty And Cells(i, col).MergeCells Then
          Scol = Cells(i, col).MergeArea.Columns.Count
          MrgeWdth = 0
          tmp = Cells(i, col).Column & Cells(i, col + Scol - 1).Column
          For j = 1 To Scol
            MrgeWdth = MrgeWdth + Cells(i, col + j - 1).ColumnWidth + 0.75
          Next j
          If Not .exists(tmp) Then
            k = k + 1
            .Add tmp, k
            Cells(1, 29 + k).ColumnWidth = MrgeWdth
          End If
          jk = .Item(tmp)
          Arr(i, jk) = Cells(i, col).Value
          Cells(i, 29 + jk).Font.Size = Cells(i, col).Font.Size
          If Cells(i, col).Font.Bold = True Then Cells(i, 29 + jk).Font.Bold = True
          If Cells(i, col).Font.Italic = True Then Cells(i, 29 + jk).Font.Italic = True
          If Cells(i, col).Font.Underline = xlUnderlineStyleSingle Then Cells(i, 29 + jk).Font.Underline = xlUnderlineStyleSingle
          col = col + Scol - 1
        End If
      Next col
    End If
  Next i
End With
Range("AD" & fRow).Resize(UBound(Arr), k) = Arr
Range("AD" & fRow).Resize(UBound(Arr), k).WrapText = True

For i = fRow To lRow
    If Len(sArr(i, 1)) Then
      Rows(i).EntireRow.AutoFit
      Rows(i).RowHeight = Rows(i).RowHeight
    End If
Next i
Range("AD" & fRow).Resize(UBound(Arr), k).Clear
'Khong ro code duoi muc dich lam gi ???

On Error Resume Next
ActiveWindow.View = xlPageBreakPreview
fP = ActiveSheet.HPageBreaks.Count
fCurr = ActiveSheet.HPageBreaks(fP).Location.Row
NumberRow = lRow - fRow
If fCurr > lRow Then
    DeltaRowHei = Range("E" & lRow & ":E" & fCurr).Height / NumberRow
    For i = lRow To fRow Step -1
        If Range("C" & i).EntireRow.Hidden = False Then _
                Range("C" & i).RowHeight = Range("C" & i).RowHeight + DeltaRowHei + 16.5 / 5
    Next i
End If
ActiveWindow.View = xlNormalView
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Chào anh!
Nhờ
PacificPR và anh @HieuCD giúp em giải thích sơ sơ về đoạn code trên được không ạ?
Em muốn ngắt trang in ở dòng bất kỳ nào đó thì phảo thay đổi, chình sửa phần nào trong code ạ!
 
Upvote 0
HieuCD đã viết:
Chỉnh lại code
Mã: 
Sub AutoFitRowHeight()
  Dim fRow As Long, lRow As Long, NumberRow As Long
  Dim i As Long, jk As Long, k As Long
  Dim DeltaRowHei As Double, fCurr As Long, fP As Long
  Dim MrgeWdth As Double
  Dim col As Byte, Scol As Byte, j As Byte
  Dim Arr(), sArr()
  Dim tmp As String
Application.ScreenUpdating = False
i = Range("B65000").End(xlUp).Row
If i < 7 Then Exit Sub 'Khong co dong fit
sArr = Range("B1:B" & i).Value
For i = 7 To UBound(sArr)
  If UCase(sArr(i, 1)) = "X" And Range("B" & i).EntireRow.Hidden = False Then
    lRow = i
    If fRow = 0 Then fRow = i
  Else
    sArr(i, 1) = Null
  End If
Next i
If lRow = 0 Then Exit Sub 'Khong co dong fit
'Phan fix row

ReDim Arr(fRow To lRow, 1 To 20)
With CreateObject("scripting.dictionary")
  For i = fRow To lRow
    If Len(sArr(i, 1)) Then
      For col = 3 To 27
        If Cells(i, col) <> Empty And Cells(i, col).MergeCells Then
          Scol = Cells(i, col).MergeArea.Columns.Count
          MrgeWdth = 0
          tmp = Cells(i, col).Column & Cells(i, col + Scol - 1).Column
          For j = 1 To Scol
            MrgeWdth = MrgeWdth + Cells(i, col + j - 1).ColumnWidth + 0.75
          Next j
          If Not .exists(tmp) Then
            k = k + 1
            .Add tmp, k
            Cells(1, 29 + k).ColumnWidth = MrgeWdth
          End If
          jk = .Item(tmp)
          Arr(i, jk) = Cells(i, col).Value
          Cells(i, 29 + jk).Font.Size = Cells(i, col).Font.Size
          If Cells(i, col).Font.Bold = True Then Cells(i, 29 + jk).Font.Bold = True
          If Cells(i, col).Font.Italic = True Then Cells(i, 29 + jk).Font.Italic = True
          If Cells(i, col).Font.Underline = xlUnderlineStyleSingle Then Cells(i, 29 + jk).Font.Underline = xlUnderlineStyleSingle
          col = col + Scol - 1
        End If
      Next col
    End If
  Next i
End With
Range("AD" & fRow).Resize(UBound(Arr), k) = Arr
Range("AD" & fRow).Resize(UBound(Arr), k).WrapText = True

For i = fRow To lRow
    If Len(sArr(i, 1)) Then
      Rows(i).EntireRow.AutoFit
      Rows(i).RowHeight = Rows(i).RowHeight
    End If
Next i
Range("AD" & fRow).Resize(UBound(Arr), k).Clear
'Khong ro code duoi muc dich lam gi ???

On Error Resume Next
ActiveWindow.View = xlPageBreakPreview
fP = ActiveSheet.HPageBreaks.Count
fCurr = ActiveSheet.HPageBreaks(fP).Location.Row
NumberRow = lRow - fRow
If fCurr > lRow Then
    DeltaRowHei = Range("E" & lRow & ":E" & fCurr).Height / NumberRow
    For i = lRow To fRow Step -1
        If Range("C" & i).EntireRow.Hidden = False Then _
                Range("C" & i).RowHeight = Range("C" & i).RowHeight + DeltaRowHei + 16.5 / 5
    Next i
End If
ActiveWindow.View = xlNormalView
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
dạ em chào anh ạ... anh có thể ghi chú cho em dòng code nào ở trên là để ngắt trang tại vị trí " Khi sang trang mới tối tiểu có hàng này" trong file được không ạ. em xin cảm ơn ạ..
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

Bich2B
lỗi định dạng ngày không đọc được công thức excel
Trả lời
6
Đọc
83
Bich2B
Bich2B
P
Finest Сasual Dating - Verified Damsels
Trả lời
0
Đọc
15
phuoctho2009
P
A
Đếm dữ liệu với điều kiện
Trả lời
12
Đọc
133
adambaylin
A
S
Nhờ giúp đỡ code in toàn bộ danh sách có điều kiện
Trả lời
2
Đọc
77
S.Ha
S
A
Excel thiếu dữ liệu
Trả lời
4
Đọc
123
Mr.hieudoanxd
Mr.hieudoanxd
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom