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

Liên hệ QC

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
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 ạ..
Bạn nói rỏ hơn " Khi sang trang mới tối tiểu có hàng này" là hàng nào trong file, code lâu rồi nên mình không nhớ rỏ yêu cầu
 
Upvote 0

File đính kèm

  • Ngat trang co dieu kien (1).xlsm
    29.9 KB · Đọc: 17
  • ảnh.png
    ảnh.png
    127.3 KB · Đọc: 12
Upvote 0
Em xin gửi anh ạ... dòng chữ màu đỏ ạ
Mình chỉ chỉnh tăng tốc tí không viết sang trang
Viết thêm tạm xử lý sang trang, chưa kiểm tra hết các khả năng
Cột B nhập từ "FR" tại dòng bắt đầu trang mới
Mã:
Option Explicit
Sub AutoFitRowHeight()
  Dim fRow As Long, lRow As Long, NumberRow As Long, fR2 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
  If UCase(Arr(i, 1)) = "FR" Then fR2 = i
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

'Dong dau khi sang trang moi
ActiveWindow.View = xlPageBreakPreview
fP = ActiveSheet.HPageBreaks.Count
fCurr = ActiveSheet.HPageBreaks(fP).Location.Row
If fCurr < Range("D65000").End(xlUp).Row Then
  NumberRow = fR2 - fRow
  If fR2 = 0 Then fR2 = lRow
  If fCurr > fR2 Then
    DeltaRowHei = (Range("E" & lRow & ":E" & fCurr).Height - Range("E" & lRow & ":E" & fR2).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
End If
ActiveWindow.View = xlNormalView
Application.ScreenUpdating = True
End Sub
 
Upvote 0
Mình chỉ chỉnh tăng tốc tí không viết sang trang
Viết thêm tạm xử lý sang trang, chưa kiểm tra hết các khả năng
Cột B nhập từ "FR" tại dòng bắt đầu trang mới
Mã:
Option Explicit
Sub AutoFitRowHeight()
  Dim fRow As Long, lRow As Long, NumberRow As Long, fR2 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
  If UCase(Arr(i, 1)) = "FR" Then fR2 = i
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

'Dong dau khi sang trang moi
ActiveWindow.View = xlPageBreakPreview
fP = ActiveSheet.HPageBreaks.Count
fCurr = ActiveSheet.HPageBreaks(fP).Location.Row
If fCurr < Range("D65000").End(xlUp).Row Then
  NumberRow = fR2 - fRow
  If fR2 = 0 Then fR2 = lRow
  If fCurr > fR2 Then
    DeltaRowHei = (Range("E" & lRow & ":E" & fCurr).Height - Range("E" & lRow & ":E" & fR2).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
End If
ActiveWindow.View = xlNormalView
Application.ScreenUpdating = True
End Sub
dạ em cảm ơn đã giúp ạ
 
Upvote 0
Mình chỉ chỉnh tăng tốc tí không viết sang trang
Viết thêm tạm xử lý sang trang, chưa kiểm tra hết các khả năng
Cột B nhập từ "FR" tại dòng bắt đầu trang mới
Mã:
Option Explicit
Sub AutoFitRowHeight()
  Dim fRow As Long, lRow As Long, NumberRow As Long, fR2 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
  If UCase(Arr(i, 1)) = "FR" Then fR2 = i
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

'Dong dau khi sang trang moi
ActiveWindow.View = xlPageBreakPreview
fP = ActiveSheet.HPageBreaks.Count
fCurr = ActiveSheet.HPageBreaks(fP).Location.Row
If fCurr < Range("D65000").End(xlUp).Row Then
  NumberRow = fR2 - fRow
  If fR2 = 0 Then fR2 = lRow
  If fCurr > fR2 Then
    DeltaRowHei = (Range("E" & lRow & ":E" & fCurr).Height - Range("E" & lRow & ":E" & fR2).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
End If
ActiveWindow.View = xlNormalView
Application.ScreenUpdating = True
End Sub
Bác có thể thêm hướng dẫn vào Code trên. E chưa thạo cái này mà đang cần. E cảm ơn
 
Upvote 0
Web KT
Back
Top Bottom