HÀM FITROW - Co giãn dòng tự động tối ưu nhất cho Excel v2.44 (*28/12/2024)

NHG · 18/4/21

Cách viết code rất chỉnh chu và chuyên nghiệp

monkeyit · 18/4/21

bác ơi em hỏi thêm chút. vì danh sách lọc em có thể thay đổi nên địa chỉ cần giãn dòng sẽ thay đổi, vậy làm sao để áp dụng hàm của bác được ạh

HeSanbi đã viết:
2. Cách viết hàm đơn lẻ cho từng vùng sẽ tiết kiệm, và code sẽ chạy nhanh hơn:
=S_FitRow(A1:Z1)
=S_FitRow(A2:Z2)
=S_FitRow(A3:Z4)

quyenpv · 18/4/21

Cái này muốn áp dụng cho VBA đại khái như khi xuất kết quả sau khi làm gì đó mà áp dụng hàm của anh để cho AutoFit kết quả thì làm như thế nào ạ

Mã:

 If K Then
        .Range("A9").Resize(K, 10) = Res
        .Range("A9").Resize(K, 10).Font.Name = "Calibri"
        .Range("A9").Resize(K, 10).Font.Size = 9
        .Range("A10").Resize(K, 10).Borders(xlInsideHorizontal).LineStyle = xlContinuous
        .Range("B9").Resize(K).WrapText = 1
        .Range("A9").Resize(K, 10).VerticalAlignment = xlCenter
        .Range("J9").Resize(K).NumberFormat = "0.0%"
        .Range("E9:F" & 9 + K).NumberFormat = "dd/mm"
        'Can chinh do rong cua hang
        If .rows("9:" & 9 + K & "").RowHeight < 20 Then
            .rows("9:" & 9 + K & "").RowHeight = 24
        Else
            .rows("9:" & 9 + K & "").EntireRow.AutoFit
        End If
        .PageSetup.PrintArea = "$A$1:$J" & i + 2 & ""
    End If

HeSanbi · 19/4/21

quyenpv đã viết:

Cái này muốn áp dụng cho VBA đại khái như khi xuất kết quả sau khi làm gì đó mà áp dụng hàm của anh để cho AutoFit kết quả thì làm như thế nào ạ

Mã:

 If K Then
        .Range("A9").Resize(K, 10) = Res
        .Range("A9").Resize(K, 10).Font.Name = "Calibri"
        .Range("A9").Resize(K, 10).Font.Size = 9
        .Range("A10").Resize(K, 10).Borders(xlInsideHorizontal).LineStyle = xlContinuous
        .Range("B9").Resize(K).WrapText = 1
        .Range("A9").Resize(K, 10).VerticalAlignment = xlCenter
        .Range("J9").Resize(K).NumberFormat = "0.0%"
        .Range("E9:F" & 9 + K).NumberFormat = "dd/mm"
        'Can chinh do rong cua hang
        If .rows("9:" & 9 + K & "").RowHeight < 20 Then
            .rows("9:" & 9 + K & "").RowHeight = 24
        Else
            .rows("9:" & 9 + K & "").EntireRow.AutoFit
        End If
        .PageSetup.PrintArea = "$A$1:$J" & i + 2 & ""
    End If

Nếu ô không có gộp thì bạn chỉ cần:
1. Tắt chế độ Page Break View: ActiveWindow.View = xlNormalView
2. Xóa PrintArea trước khi co giãn bằng phương thức AutoFit

Sau đó bạn chỉ cần mở lại chế độ In nếu bạn cần:
ActiveWindow.View = xlPageBreakView
Và đặt lại PrintArea

monkeyit đã viết:
bác ơi em hỏi thêm chút. vì danh sách lọc em có thể thay đổi nên địa chỉ cần giãn dòng sẽ thay đổi, vậy làm sao để áp dụng hàm của bác được ạh

Nếu bạn lọc bằng phương thức Filter thì sau khi lọc, Vùng đã lọc nhập vào hàm: =S_FitRow(FilterCells, 5, 40)

monkeyit · 19/4/21

HeSanbi đã viết:
Nếu ô không có gộp thì bạn chỉ cần:
1. Tắt chế độ Page Break View: ActiveWindow.View = xlNormalView
2. Xóa PrintArea trước khi co giãn bằng phương thức AutoFit

Sau đó bạn chỉ cần mở lại chế độ In:
ActiveWindow.View = xlNormalView
Và đặt lại PrintArea

Nếu bạn lọc bằng phương thức Filter thì sau khi lọc, Vùng đã lọc nhập vào hàm: =S_FitRow(FilterCells, 5, 40)

Cảm ơn bác. e sẽ thử xem sao

HeSanbi · 19/4/21

*** CẬP NHẬT MỚI NHẤT: 10:00 19/4/2021 ***
Hoàn thiện code, cải thiện tốc độ chạy code cho một số trường hợp như chế độ Xem In Ấn hoặc không.

Thêm 2 tham số:
1. Đặt chiều cao mặc định khi vùng cần co giãn tất cả giá trị rỗng
2. Lựa chọn co giãn kể cả ô không ở chế độ WrapText

phuongnam366377 · 19/4/21

To @HeSanbi
Sao Mạnh tải về thử nó ko có nhúc nhích gì hết vậy
Cái vùng kéo vào nó Hide đi thấy nó cũng IM RE vậy

Windows10_x64 + Office2016_x64

HeSanbi · 19/4/21

phuongnam366377 đã viết:
To @HeSanbi
Sao Mạnh tải về thử nó ko có nhúc nhích gì hết vậy
Cái vùng kéo vào nó Hide đi thấy nó cũng IM RE vậy

Windows10_x64 + Office2016_x64

Tôi sợ là bác chưa đọc hết bài viết của tôi ở trên thôi.
Chứ bài viết chỉ có đề cập đến gõ hàm và tự động. Hoàn toàn không có "kéo cái gì vào". Nên tôi không biết là bác có hỏi nhầm mục đích của hàm tôi viết không.

Và code có thể hoạt động ở nhiều nền tảng Window và Office.

HeSanbi · 19/4/21

*** CẬP NHẬT MỚI NHẤT: 18:30 19/4/2021 ***
Cập nhật thay đổi giải thuật co giãn dòng

HeSanbi · 20/4/21

*** CẬP NHẬT MỚI NHẤT: 13:30 20/4/2021 ***

+ Thêm tính năng co giãn chính ô viết Hàm
+ Thêm các tham số:

Đặt chiều cao mặc định khi vùng cần co giãn tất cả giá trị rỗng
Thêm lựa chọn co giãn kể cả ô không ở chế độ WrapText
Thêm tham số đặt chiều cao mặc định cho cả dòng có giá trị rỗng
Thêm lựa chọn hàm sẽ chỉ thực thi tại Trang tính hiện hành để tăng tốc, các hàm co giãn ở Trang tính khác sẽ ở trạng thái chờ nếu có lựa chọn này.

Bản cập nhật tiếp theo sẽ có những gì:

Thêm các yếu tố co giãn cho đẹp, và phù hợp hơn
Sẽ có tính năng giãn Trang, như các mục, chỉ mục, vừa khớp với Trang hoặc dịch chuyển mục, chỉ mục xuống Trang mới nếu nội dung mục, chỉ mục bị tách ra Trang mới.

quanglenb · 21/4/21

HeSanbi đã viết:

*** CẬP NHẬT MỚI NHẤT: 13:30 20/4/2021 ***

+ Thêm tính năng co giãn chính ô viết Hàm
+ Thêm các tham số:

Đặt chiều cao mặc định khi vùng cần co giãn tất cả giá trị rỗng
Thêm lựa chọn co giãn kể cả ô không ở chế độ WrapText
Thêm tham số đặt chiều cao mặc định cho cả dòng có giá trị rỗng
Thêm lựa chọn hàm sẽ chỉ thực thi tại Trang tính hiện hành, các hàm co giãn ở Trang tính khác sẽ ở trạng thái chờ nếu có lựa chọn này.

Bản cập nhật tương lai:
+ Sẽ có bản cập nhật để sửa cho chính xác một số trường co giãn chưa đẹp
+ Sẽ có hỗ trợ điều chỉnh văn bản, như các mục, chỉ mục, vừa khớp với Trang hoặc dịch chuyển mục, chỉ mục xuống Trang mới nếu nội dung mục, chỉ mục bị tách ra Trang mới.

Hôm nay tôi lại chia sẻ cho các bạn một Hàm VBA UDF có chức năng tự động co giãn dòng khi giá trị trong bảng tính thay đổi, thì quá trình co giãn dòng cũng tự động thay đổi theo.
Code bên dưới là phiên bản đầu nên có thể gặp một số lỗi nhất định, nên khi tham khảo thì các bạn nên kiểm trước, nếu code hoạt động ổn định thì các bạn có thể sử dụng.

Tôi quyết định viết code này bỡi vì trên diễn đàn có nhiều bài viết hỏi về co giãn dòng tự động, và khi tôi đọc qua các bài viết đó thì không thấy ai có thể xử lý vấn đề triệt để, hoặc là code chưa tối ưu, hoặc code chưa xử lý được nhiều vùng đã gộp cùng dòng.

Và hàm UDF là một cách tối ưu nhất giúp các bạn không phải code lại, mà chỉ cần viết Hàm như một hàm Excel bình thường để thực hiện tác vụ co giãn dòng.

HÀM UDF TỰ ĐỘNG CO GIÃN DÒNG

với Hàm S_FitRow

Chức năng ưu việt của hàm:

Co giãn dòng hoàn toàn tự động.
Co giãn dòng kể cả các ô đã được gộp.
Co giãn dòng với các giá trị nhiều ô cùng dòng.
Hoạt động cả ở chế độ Xem In Ấn
Thêm một chiều cao nhất định sau khi giản dòng.
Vì dùng hàm UDF nên rất tối ưu, tiết kiệm CPU.

Hướng dẫn sử dụng hàm:

Vị trí	Tham số	Kiểu	Chức năng
1	Target	Vùng cần giãn dòng	Nhận vùng cần co giãn
2	Margin	Kiểu số	Tăng chiều cao thêm một số
3	defaultHeight	Kiểu số	Chiều cao mặc định nếu giá trị rỗng
4	HeightOfRowNull	Kiểu số	Đặt chiều cao cho cả dòng rỗng
5	IncludeNoWrap	Có/Không	Co giãn kể cả ô không WapText
6	OnlySheetVisible	Có/Không	Chỉ giãn dòng ở Trang hiện hành
7	Title	Chuỗi	Chuỗi bất kì do người dùng đặt (Nếu không thì trả về giá trị là Fit:{vùng})

Cách viết hàm nhanh, gõ vào ô chuỗi =S_FitRow và ấn tổ hợp phím Ctrl+Shift+A.

Viết hàm nhanh: =S_FitRow(A2)
Viết hàm có cài đặt đối số: =S_FitRow(A2,5,40,False)

Ví dụ: =S_FitRow(A1:E9, 5, 40, FALSE)
+ A1:E9 là vùng cần co giãn
+ 5 là tăng thêm chiều cao 5 đơn vị
+ 40 là chiều cao mặc định nếu tất cả giá trị rỗng
+ FALSE thì ô không WapText thì không co giãn
Cũng có thể gõ nhanh =S_FitRow(A1:E9) bỏ qua các cài đặt

Cách viết hàm như sau sẽ co giãn chính ô viết hàm:

1. Khi nhập chuỗi:

=S_FitRow("Chuỗi",5)

2. Khi tham chiếu giá trị thì đóng dấu ngoặc tròn ô tham chiếu:

=S_FitRow((A2),5)

Cách viết hàm như sau sẽ co giãn vùng tham chiếu:

=S_FitRow(B26: D35,5)

Ví dụ: Cần co giãn các ô như sau: B28:C31, D28:E28, D29: D30, E29:E31, D31

Thì viết hàm: =S_FitRow(B28:E31,5)

Để có thể co giãn các ô cùng dòng và đã gộp ô

Các phương thức Bổ trợ:
1. Gõ hàm S_FitRow_OFF: nếu đang chỉnh sửa trang tính hãy tắt chế độ co giãn dòng hoặc bật chế độ Design Mode trong Tab Developer.
2. Gõ hàm S_FitRow_ON: Nếu đã tắt chế độ co giãn dòng tự động thì bật lên.
3. Thủ tục S_FitRow_Toggle + Check box có tên là chxAutoFitRow dùng để bật tắt chế độ co giãn dòng nếu muốn (Ví dụ nằm ở Sheet1 trong tập tin đính kèm bên dưới).

Bước 3 này là một thủ thuật để ngăn chặn code tính toán lúc ứng dụng vừa khởi động, vì có thể sẽ gặp phải tình trạng code sẽ làm chậm quá trình khởi động.

Hãy để dòng code sau vào sự kiện Workbook_Open: Call S_FitRow_Off

Hãy mở lại bằng bước 2 hoặc bước 3.

*** Nếu bạn viết quá nhiều công thức hàm S_FitRow thì không thể thiếu bước 3 này

Cách nhập nhiều mảng:

Sử dụng hàm S_Cells hàm tự tạo: =S_FitRow(S_Cells(A1:C9,D2: D3,E5:E6), 5, 40)

Hướng dẫn tận dụng hàm:
Với 2 ví dụ sau:
1. Cách viết hàm tổng quát như sau sẽ gây chậm và tiêu tốn CPU:
=S_FitRow(A1:Z500)

2. Cách viết hàm đơn lẻ cho từng vùng sẽ tiết kiệm, và code sẽ chạy nhanh hơn:
=S_FitRow(A1:Z1)
=S_FitRow(A2:Z2)
=S_FitRow(A3:Z4)

Tức là hãy nhập vùng cho hàm sao cho vùng đó tương ứng với số dòng ô được gộp lớn nhất của dòng tương ứng.
Nếu ta có các vùng được gộp là A1:C9, D2: D3, E5:E6, thì rõ ràng là A1:C9 có các dòng chứa hết các vùng còn lại,
nên ta viết: =S_FitRow(A1:E9)

Những lỗi có thể xảy ra:

Vì code sẽ mượn một ô trong trang tính làm ô để giãn dòng, vì vậy nếu hàm có vùng tham chiếu giao với ô được mượn thì xảy ra lỗi.
Nếu có hai hàm có tham chiếu là hai vùng giao nhau có thể xảy ra lỗi.
Nếu trang tính hoặc ô tham chiếu đang khóa, cũng có thể xảy ra lỗi.

*** Các bạn lưu ý code có thể chưa được tối ưu nhất, nên có thể cập nhật lại nhiều lần, nên nếu các bạn có sử dụng code thì nên thường xuyên xem lại bài viết, sẽ có thông báo cập nhật nếu có ở đầu bài viết.

PHP:

Option Explicit
Private Type PARAMIndex
  value As String
  Cell As Excel.Range
  Cells As Excel.Range
  Minimum As Single
  RowHeight As Single
  OneLine As Boolean
  More  As Boolean
End Type

Private Type TypeArguments
  Action As Long
  Target As Variant
  Caller As Range
  Formula As String
  Margin As Single
  defaultHeight As Single
  HeightOfRowNull As Single
  IncludeNoWrap As Boolean
  OnlySheetVisible As Boolean
  Cells As Excel.Range
End Type
#If VBA7 Then
  Public Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
  Public Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
  Public Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
  Public Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If
''///////////////////////////////////////////////////////
#If VBA7 And Win64 Then
  Private gTimerID As LongPtr
#Else
  Private gTimerID As Long
#End If
''///////////////////////////////////////////////////////
Private Works() As TypeArguments, FitUnable As Boolean

Private Const MaxH = 1450, MaxV = 409

Function S_Cells(ParamArray Cells())
  Dim c, R As Range
  For Each c In Cells
    If TypeName(c) = "Range" Then
      If R Is Nothing Then
        Set R = c
      Else
        If R.Parent Is c.Parent Then
          Set R = Union(c, R)
        End If
      End If
    End If
  Next
  Set S_Cells = R
End Function

Private Sub S_FitRow_Toggle()
  With ActiveSheet.CheckBoxes("chxAutoFitRow")
    FitUnable = .value <> 1
  End With
End Sub

Function S_FitRow_ON()
  FitUnable = False
End Function

Function S_FitRow_Off()
  FitUnable = True
End Function


Function S_FitRow(Optional ByVal Target, _
    Optional ByVal Margin!, _
    Optional ByVal defaultHeight!, _
    Optional ByVal HeightOfRowNull!, _
    Optional ByVal IncludeNoWrap As Boolean, _
    Optional ByVal OnlySheetVisible As Boolean, _
    Optional ByVal Title$ = vbNullChar) As String
  On Error Resume Next

  Dim R As Object, k&, i&, s$
  s = Target.Address(0, 0)
  Set R = Application.Caller

  Select Case True
  Case TypeName(Target) <> "Range"
    S_FitRow = Target
    Set Target = R
  Case LCase(R.Formula) Like "*s_fitrow((" & LCase(s) & ")*" And Target.Cells.Count = 1
    S_FitRow = Target(1, 1).value
    Set Target = R
  Case Title = vbNullChar
    S_FitRow = "Fit=" & s
  Case Else
    S_FitRow = Title
  End Select
  If FitUnable Then
    Exit Function
  End If

  k = UBound(Works)
  If k > 0 Then
    For i = 1 To k
      With Works(i)
        If Not .Target Is Nothing Then
          If .Formula = R.Formula _
          And .Target.Parent Is Target.Parent _
          And .Target.Address = Target.Address Then
            .Action = 0
            GoTo n
          End If
        End If
      End With
    Next
  End If

  k = k + 1
  ReDim Preserve Works(1 To k)

  With Works(k)
    .defaultHeight = defaultHeight
    .HeightOfRowNull = HeightOfRowNull
    Set .Caller = R
    Set .Target = Target
    .Margin = Margin
    .Formula = R.Formula
    .IncludeNoWrap = IncludeNoWrap
    .OnlySheetVisible = OnlySheetVisible
  End With
n:
  Set R = Nothing

  If gTimerID = 0 Then
    gTimerID = SetTimer(0&, 0&, 0, AddressOf S_FitRow_callback)
  End If
End Function

Private Sub S_FitRow_callback()
  On Error Resume Next
  Call KillTimer(0&, gTimerID)
  gTimerID = 0
  S_FitRow_working
  On Error GoTo 0
End Sub

Private Sub S_FitRow_test2()

  'Application.CutCopyMode = xlCopy
  'Application.CutCopyMode = xlCut
  [A7].Copy [A8]
  'Application.CutCopyMode = xlCut
  'Application.CutCopyMode = xlCopy
'   Dim R
'   Static s&
'   s = s + 1
'   Set R = [A4]
'   R.Resize(4, 1).value = s
End Sub
Private Sub S_FitRow_test()
   Dim R
   Set R = [A9]
   Application.Calculation = xlCalculationManual
   R(1, 1).Formula = "=S_FitRow($A$3:$H$3, 5,40,FALSE,TRUE)"
   R(2, 1).Formula = "=S_FitRow($A$4:$H$4, 5,40,FALSE,TRUE)"
   R(3, 1).Formula = "=S_FitRow($A$5:$H$5, 5,40,FALSE,TRUE)"
   R(4, 1).Formula = "=S_FitRow($A$6:$H$6, 5,40,FALSE,TRUE)"
   R(5, 1).Formula = "=S_FitRow($A$7:$H$7, 5,40,FALSE,TRUE)"
   Application.Calculation = xlCalculationAutomatic
End Sub
''///////////////////////////////////////////////////////
Private Sub S_FitRow_working()

  On Error Resume Next
  Dim UB As Integer, A As Object, B As TypeArguments, i&, k&, n&, su As Boolean
  Dim W As Object, Hl As Object, HlText As Variant
  Set Hl = VBA.CreateObject("htmlfile")
  HlText = Hl.parentWindow.clipboardData.GetData("Text")
  UB = UBound(Works)
  For i = 1 To UB
    B = Works(i)

    If B.Action = 0 Then
      If B.Caller.Formula = B.Formula Then
        If B.OnlySheetVisible Then
          Set W = Nothing
          Set W = B.Target.Parent.Parent.ActiveSheet
          If Not B.Target.Parent Is W Then
            GoTo n
          End If
        End If
        If A Is Nothing Then
          Set A = B.Target.Parent.Parent.Parent
          su = A.ScreenUpdating
          If su Then A.ScreenUpdating = False
        End If
        Works(i).Action = 1
        If B.Caller.Address = B.Target.Address Then
          B.Caller.WrapText = True
        End If
        Call S_FitRow_Final(B.Target, B.Margin, B.defaultHeight, B.HeightOfRowNull, B.IncludeNoWrap)
      End If
    End If
    k = k + 1
n:
  Next
  If k >= UB Then
    Erase Works
  End If
  If Not A Is Nothing Then
    If su And A.ScreenUpdating <> su Then
      A.ScreenUpdating = su
    End If
    Set A = Nothing
  End If
  If Len(HlText) Then
    Hl.parentWindow.clipboardData.setData "Text", HlText
  End If
  Set W = Nothing
  Set Hl = Nothing
  On Error GoTo 0
End Sub

Private Sub S_FitRow_Final_test()
  Call S_FitRow_Final(Array(Sheet1.[A3:F7], Sheet2.[A3:F7], Sheet1.[A10]), 5, 40, False)
End Sub

Private Sub S_FitRow_Final( _
                         ByVal Target, _
                Optional ByVal Margin!, _
                Optional ByVal defaultHeight!, _
                Optional ByVal HeightOfRowNull! = 15, _
                Optional ByVal IncludeNoWrap As Boolean)
  If Margin < 0 Then
    Margin = 0
  End If
  If defaultHeight < 0 Then
    defaultHeight = 0
  End If
  If HeightOfRowNull < 0 Then
    HeightOfRowNull = 0
  End If
  Dim WS As Excel.Worksheet
  Dim Tg2 As Excel.Range
  Dim NewCell As Excel.Range
  Dim CCell As Excel.Range
  Dim Contain As Excel.Range
  Dim CellMergeArea As Excel.Range
  Dim Ar As Excel.Range
  Dim Ars As Excel.Range
  Dim P1 As VBA.Collection
  Dim P2 As VBA.Collection
  Dim P_, A, Area, Areas, Cell
  Dim line&, su As Boolean
  Dim Z() As PARAMIndex, Arrs(), st(), nArr(1 To 4)
  Dim i&, R&, k&, n%, ni%, ii&, jj%, ij%, W As Boolean
  Dim FromLine&, ToLine&, RowCount&, RC2&
  Dim H As Single, H2 As Single, H3 As Single, H4 As Single, H5 As Single
  Dim WindowView As Integer
  Dim Surplus As Single, More As Boolean, mul As Boolean
  Dim LastRow&, LastCol%

  Set P1 = New VBA.Collection
  If Not IsArray(Target) Then
    Areas = Array(Target)
  Else
    Areas = Target
  End If
Rep:
  For Each Areas In Target
    If TypeName(Areas) = "Range" Then
      If WS Is Nothing Then
        Set WS = Areas.Parent
        Set A = WS.Parent.Parent
        su = A.ScreenUpdating
        If su Then A.ScreenUpdating = False
        WindowView = getWindowView(WS)
        GoSub A
      Else
        If Not WS Is Areas.Parent Then
          Set Contain = Nothing
          Set WS = Areas.Parent
          WindowView = getWindowView(WS)
          GoSub A
        End If
      End If
      For Each Area In Areas.Areas
        ij = 0
        For ii = 1 To Area.rows.Count
          For jj = 1 To Area.Columns.Count
            GoSub Area
          Next
        Next
        If ij = 0 And defaultHeight > 0 Then
          If Tg2 Is Nothing Then
            Set Tg2 = Area
          Else
            Set Tg2 = Union(Area, Tg2)
          End If
        End If
      Next
      Set st(1, ni) = Contain
    End If
  Next
  If Not mul Then
    mul = True: GoTo Rep
  End If
  If Not Tg2 Is Nothing Then
    For Each Area In Tg2.Areas
      GoSub r3
    Next
  End If
Ends:
  GoSub finish
Exit Sub
A:
  ni = 0
  If n > 0 Then
    For i = 1 To n
      If IsObject(st(1, n)) Then
        If st(1, n).Parent Is WS Then
          ni = n
          Set Contain = st(1, n)
          Set CCell = st(2, n)
          Exit For
        End If
      End If
    Next
  End If
  If ni = 0 Then
    n = n + 1: ni = n
    ReDim Preserve st(1 To 4, 1 To n)
    st(3, n) = 8.38
    st(4, n) = 15
    Set Contain = Nothing
    Set CCell = Nothing
  End If
Return
Area:
  Set Cell = Area(ii, jj)

  If Cell.value <> vbNullString Then
    If Cell.WrapText Or IncludeNoWrap Then
      Set CellMergeArea = Cell.MergeArea
      If Contain Is Nothing Then
        GoSub rows
      Else
        If Intersect(CellMergeArea, Contain) Is Nothing Then
          GoSub rows
        End If
      End If
    End If
  End If
Return


rows:
  ij = ij + 1
  If Not Cell.EntireRow.Hidden Then
    W = False: More = False
    RowCount = CellMergeArea.rows.Count
    FromLine = Cell.Row
    ToLine = FromLine + RowCount - 1
    If ToLine > line Then
      line = ToLine
      ReDim Preserve Z(1 To line)
    End If

    If WS.PageSetup.PrintArea <> vbNullString _
    Or WindowView = 2 Or CellMergeArea.Cells.Count > 1 Or More Then
      If mul Then
        GoSub Add
        GoSub CopyCell
        Set NewCell = CCell
      End If
    Else
      If Not mul Then
        GoSub Add
        With Z(FromLine)
          If .More Then
            More = True
          Else
            GoSub getMore
            .More = More
          End If
        End With
        If More Then
          GoSub CopyCell
          Set NewCell = CCell
        Else
          Set NewCell = Cell
          W = True
        End If
      End If
    End If
    If W Then
      NewCell.WrapText = False
      NewCell.WrapText = True
      NewCell.rows.AutoFit
      H = NewCell.Height + Margin
      ''
      With Z(FromLine)
        If .OneLine And Not More Then
          If Cell.MergeCells Then
            GoSub SameRow
          End If
        Else
          GoSub SameRow
          .OneLine = Not More And Not Cell.MergeCells
        End If
      End With
    End If
  End If
Return

SameRow:
  H5 = 0
  For i = FromLine To ToLine
    If Not Z(i).Cell Is Nothing Then
      H5 = H5 + Z(i).RowHeight
    End If
  Next
  If H - H5 <= 0 Then
    Return
  End If
  If H5 > 0 And H - H5 > 0 Then
    H2 = (H - H5) / RowCount
    For i = FromLine To ToLine
      Z(i).RowHeight = Z(i).RowHeight + H2
    Next
  Else
    H2 = H / RowCount
    For i = FromLine To ToLine
      On Error Resume Next
      If P1(CStr(i)) = 0 Then
        P1.Add i, CStr(i)
      End If
      On Error GoTo 0
      With Z(i)
        If .Cell Is Nothing Then
          Set .Cell = WS.Cells(i, 1)
          .RowHeight = H2
          If RowCount = 1 Then
            .Minimum = H2
          End If
          Set .Cells = CellMergeArea
        Else
          If .Minimum > 0 Then
            If H2 > .Minimum Then
              Surplus = H2 - .RowHeight
              GoSub R1
              If RowCount = 1 Then
                .RowHeight = H2
              End If
            End If
          Else
            If RowCount = 1 Then
              If H2 > .Minimum Then
                .RowHeight = H2
              End If
            End If
            If H2 > .RowHeight Then
              Surplus = -H2 + .RowHeight
              .RowHeight = H2
              GoSub R
            Else
              If .Minimum Then
                .RowHeight = H2
              End If
            End If
          End If
          Set .Cells = Union(.Cells, CellMergeArea)
        End If
      End With
    Next
  End If
Return
R:
  Set Ars = Nothing
  For Each Ar In Z(i).Cells.Areas
    RC2 = Ar.rows.Count - 1
    If RC2 > 0 Then
      Set P2 = New VBA.Collection
      H4 = 0
      For R = Ar.Row To Ar.Row + RC2
        H4 = H4 + Z(R).RowHeight
        If R < FromLine Or R > ToLine Then
          If Ars Is Nothing Then
            Set Ars = WS.Cells(R, 1)
            P2.Add R, CStr(R)
          Else
            If Intersect(Ars, WS.Cells(R, 1)) Is Nothing Then
              Set Ars = Union(Ars, WS.Cells(R, 1))
              P2.Add R, CStr(R)
            End If
          End If
        End If
      Next
      GoSub r2
    End If
  Next
Return
R1:
  Set Ars = Nothing
  For Each Ar In Z(i).Cells.Areas
    RC2 = Ar.rows.Count - 1
    If RC2 > 0 Then
      Set P2 = New VBA.Collection
      H4 = 0
      For R = Ar.Row To Ar.Row + RC2
        H4 = H4 + Z(R).RowHeight
        If R < FromLine Or R > ToLine Then
          If Ars Is Nothing Then
            Set Ars = WS.Cells(R, 1)
            P2.Add R, CStr(R)
          Else
            If Intersect(Ars, WS.Cells(R, 1)) Is Nothing Then
              Set Ars = Union(Ars, WS.Cells(R, 1))
              P2.Add R, CStr(R)
            End If
          End If
        End If
      Next
      GoSub r2
    End If
  Next
Return
r2:
  If P2.Count = 0 Then
    For R = Ar.Row To Ar.Row + RC2
      If R < FromLine Or R > ToLine Then
        With Z(R)
          If .Minimum > 0 Then
            H3 = .Minimum
          Else
            H3 = 15
          End If
          If H - (.RowHeight - H3) > H4 Then
             H = H - (.RowHeight - H3)
            .RowHeight = H3
          End If
        End With
      End If
    Next
    Return
  End If

  H3 = Surplus / P2.Count

  For Each P_ In P2
    With Z(P_)
      If Not .Cell Is Nothing Then
        If .RowHeight + H3 < .Minimum Then
          P2.Remove CStr(P_)
          GoTo r2
        End If
      End If
    End With
  Next

  If P2.Count Then
    For Each P_ In P2
      With Z(P_)
        If Not .Cell Is Nothing Then
          .RowHeight = .RowHeight + Surplus / P2.Count
        End If
      End With
    Next
  End If

Return
r3:
  RowCount = Area.rows.Count
  H2 = defaultHeight / RowCount
  For i = Area.Row To Area.Row + RowCount - 1
    If Not Z(i).Cell Is Nothing Then
      Return
    End If
  Next
  For i = Area.Row To Area.Row + RowCount - 1
    With Z(i)
      If .Cell Is Nothing Then
        Set .Cell = WS.Cells(i, 1)
        .RowHeight = H2
        Set .Cells = Area
      End If
    End With
  Next
Return
getMore:
  Set Ars = Area(ii, Area.Columns.Count + 1).Resize(1, 500) _
         .Find("*", After:=Area(ii, Area.Columns.Count + 1), LookIn:=xlFormulas, LookAt:=xlWhole, SearchDirection:=xlPrevious, SearchOrder:=xlByColumns)
  If Not Ars Is Nothing Then
    More = Not Ars.MergeCells
  End If
  If Not More Then
    If Area.Column > 1 Then
      Set Ars = WS.Cells(Area.Row, 1).Resize(1, Area.Column - 1) _
         .Find("*", After:=WS.Cells(Area.Row, 1), LookIn:=xlFormulas, LookAt:=xlWhole, SearchDirection:=xlPrevious, SearchOrder:=xlByColumns)
      If Not Ars Is Nothing Then
        More = Not Ars.MergeCells
      End If
    End If
  End If
Return
ResetCell:
  If n > 0 Then
    For i = 1 To n
      If IsObject(st(2, i)) Then
        With st(2, i)
          .EntireColumn.ColumnWidth = st(3, i)
          .EntireRow.RowHeight = st(4, i)
          .Offset(50, 0).Resize(50, 50).Copy st(2, i)
        End With
      End If
    Next
    Erase st
  End If
Return

Add:
  If Contain Is Nothing Then
    Set Contain = CellMergeArea
  Else
    Set Contain = Union(CellMergeArea, Contain)
  End If
Return
CopyCell:
  '' TiÌm ô cuôìi ðêÒ thýòc hiêòn
  If CCell Is Nothing Then
    LastRow = WS.Cells.Find("*", After:=WS.Cells(1), LookIn:=xlFormulas, LookAt:=xlWhole, SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    LastCol = WS.Cells.Find("*", After:=WS.Cells(1), LookIn:=xlFormulas, LookAt:=xlWhole, SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
    Set CCell = WS.Cells(LastRow + 20, LastCol + 20)
    Do Until CCell.Formula = VBA.vbNullString And CCell.MergeArea.Cells.Count = 1
      Set CCell = CCell(2, 2)
    Loop
    st(3, ni) = CCell.EntireColumn.ColumnWidth
    st(4, ni) = CCell.EntireRow.RowHeight
    Set st(2, ni) = CCell
  End If
  CellMergeArea.Copy CCell
  CCell.value = Cell.value
  CCell.MergeArea.MergeCells = False
  W = SetNewWidthArea(CCell, CellMergeArea)
Return
finish:
  GoSub ResetCell
  '' Thýòc hiêòn giaÞn doÌng
  For Each P_ In P1
    With Z(P_)
      If .RowHeight > 0 Then
        .Cell.EntireRow.RowHeight = .RowHeight
      Else
        .Cell.EntireRow.RowHeight = HeightOfRowNull
      End If
    End With
  Next
  If A.ScreenUpdating <> su And su Then
    A.ScreenUpdating = su
  End If
  If P1.Count Then
    Erase Z
  End If
  Set P1 = Nothing
  Set P2 = Nothing
  Set A = Nothing
  Set Area = Nothing
  Set Cell = Nothing
  Set CellMergeArea = Nothing
  Set Tg2 = Nothing
  Set WS = Nothing
  Set Contain = Nothing
  Set CCell = Nothing
  Set Ar = Nothing
  Set Ars = Nothing
Return
End Sub



Private Function SetNewWidthArea(ByVal NewCell As Range, ByVal CellMerge As Range) As Boolean
  Dim W As Double, W2 As Double, i As Double
  W2 = CellMerge.Width
  If W2 > 1400 Then
    Exit Function
  End If
  W = W2 / 6.05
  NewCell.EntireColumn.ColumnWidth = W
  If NewCell.Width >= W2 Then
    Do
      W = W - 0.3
      NewCell.EntireColumn.ColumnWidth = W
    Loop Until NewCell.Width <= W2
  End If
  Do Until NewCell.Width >= W2
    W = W + 0.1
    NewCell.EntireColumn.ColumnWidth = W
  Loop
  SetNewWidthArea = True
End Function

Private Function getWindowView(ByVal WS As Excel.Worksheet) As Integer
  On Error Resume Next
  Dim W As Object, A As Object
  Set W = WS.Parent.ActiveSheet
  If Not W Is WS Then
    Dim su As Boolean
    Set A = WS.Parent.Parent.Parent
    su = A.ScreenUpdating
    If su Then
      A.ScreenUpdating = False
    End If
    WS.Activate
    getWindowView = WS.Parent.Windows(1).View
    If Not W Is Nothing Then
      W.Activate
    End If
    If A.ScreenUpdating <> su And su Then
      A.ScreenUpdating = su
    End If
    Set A = Nothing
  Else
    getWindowView = WS.Parent.Windows(1).View
  End If
  Set W = Nothing
  On Error GoTo 0
End Function

Em chào anh @HeSanbi .
Cảm ơn anh đã có chia sẻ tuyệt vời.
Em đã đọc bài viết của anh, có đôi chỗ chưa hiểu, mong anh giúp:
anh có viết:
Hướng dẫn sử dụng hàm:

Vị trí	Tham số	Kiểu	Chức năng
1	Target	Vùng cần giãn dòng	Nhận vùng cần co giãn
2	Margin	Kiểu số	Tăng chiều cao thêm một số
3	defaultHeight	Kiểu số	Chiều cao mặc định nếu giá trị rỗng
4	HeightOfRowNull	Kiểu số	Đặt chiều cao cho cả dòng rỗng
5	IncludeNoWrap	Có/Không	Co giãn kể cả ô không WapText
6	OnlySheetVisible	Có/Không	Chỉ giãn dòng ở Trang hiện hành
7	Title	Chuỗi	Chuỗi bất kì do người dùng đặt (Nếu không thì trả về giá trị là Fit:{vùng})

Cách viết hàm nhanh, gõ vào ô chuỗi =S_FitRow và ấn tổ hợp phím Ctrl+Shift+A.
Em xin được hỏi bảng chứa thông số trên là trong code hay sao ạ? khi sử dụng hàm người sử dụng có cần quan tâm đến bảng trên không ạ?
Và khi gõ vào ô chuỗi =S_FitRow và ấn tổ hợp phím Ctrl+Shift+A. thì em thấy nào báo lỗi. hay do em thao tác sai ạ?
Xin được anh chỉ dẫn.
Em xin cảm ơn anh!

HeSanbi · 21/4/21

quanglenb đã viết:
Em xin được hỏi bảng chứa thông số trên là trong code hay sao ạ?

Bài viết mình có nói gì tới code đâu, ngay tiêu đề là Hàm.
Mà Hàm UDF tức là hàm được tạo từ VBA, gọi là hàm tự tạo.

Như Hàm VLookUP (lookup_value, table_array, col_index_num, [range_lookup])
Thì Hàm trên là S_FitRow(Target, [Margin], [defaultHeight], [HeightOfRowNull], [IncludeNoWrap], [OnlySheetVisible], [Title])

Tham số có dấu ngoặc vuông là đã có giá trị mặc định, có thể điền hoặc là không.
Ví dụ: =S_FitRow(A1), =S_FitRow(A1,,,,,TRUE), ....

quanglenb đã viết:
khi sử dụng hàm người sử dụng có cần quan tâm đến bảng trên không ạ?

Bảng hướng dẫn hàm có bao nhiêu tham số, bạn mà không đọc thì sao biết cách dùng.

quanglenb đã viết:
Và khi gõ vào ô chuỗi =S_FitRow và ấn tổ hợp phím Ctrl+Shift+A

Cách Ctrl+Shift+A là phím tắt mặc định để chỉ gõ ra hàm chỉ dẫn nhanh. Vì có gợi ý nhập đối số để ta dễ dàng điền đối số.

Trên bài viết có tệp ví dụ, bạn nên vào xem cách viết hàm.

quanglenb · 21/4/21

HeSanbi đã viết:
Bài viết mình có nói gì tới code đâu, ngay tiêu đề là Hàm.
Mà Hàm UDF tức là hàm được tạo từ VBA, gọi là hàm tự tạo.

Như Hàm VLookUP (lookup_value, table_array, col_index_num, [range_lookup])
Thì Hàm trên là S_FitRow(Target, [Margin], [defaultHeight], [HeightOfRowNull], [IncludeNoWrap], [OnlySheetVisible], [Title])

Tham số có dấu ngoặc vuông là đã có giá trị mặc định, có thể điền hoặc là không.
Ví dụ: =S_FitRow(A1), =S_FitRow(A1,,,,,TRUE), ....

Bảng hướng dẫn hàm có bao nhiêu tham số, bạn mà không đọc thì sao biết cách dùng.

Cách Ctrl+Shift+A là phím tắt mặc định để chỉ gõ ra hàm chỉ dẫn nhanh. Vì có gợi ý nhập đối số để ta dễ dàng điền đối số.

Trên bài viết có tệp ví dụ, bạn nên vào xem cách viết hàm.

Vâng, xin cảm ơn anh!

quangpv328 · 14/8/21

Chủ thớt hình như đã quên dự án này rồi thì phải?

HeSanbi · 15/8/21

quangpv328 đã viết:
Chủ thớt hình như đã quên dự án này rồi thì phải?

Bạn theo dõi chủ đề, nếu có cập nhật, bạn sẽ nhận được thông báo

Mr.hieudoanxd · 19/8/21

HeSanbi đã viết:
Bạn theo dõi chủ đề, nếu có cập nhật, bạn sẽ nhận được thông báo

Bản mới "Rất Pro"

Code rất đẹp rồi có điều lúc chạy code hơi tốn thời gian. Mình nghĩ hàm UDF thì phải nhanh hơn nhiều chứ. Hóng sP mới của anh

vova2209 · 21/8/21

HeSanbi đã viết:
Bạn theo dõi chủ đề, nếu có cập nhật, bạn sẽ nhận được thông báo

Bản mới "Rất Pro"

Khi soi kính lúp trang in xong hiện ra viền định dạng in làm code chậm đi nhiều.
em cho thêm đoạn code vào đầu chạy nuột luôn:
ActiveSheet.DisplayPageBreaks = False

Bài đã được tự động gộp: 21/8/21

Mr.hieudoanxd đã viết:
Code rất đẹp rồi có điều lúc chạy code hơi tốn thời gian. Mình nghĩ hàm UDF thì phải nhanh hơn nhiều chứ. Hóng sP mới của anh

Chắc dính trường hợp giống bài #18

vova2209 · 21/8/21

HeSanbi
Chào anh! cho em hỏi
muốn co dãn từng dòng lẻ trong 1 lệnh có được không? hay phải dùng nhiều lệnh
VD: dãn ô A2 và ô C5 và D7

0983799078nxk · 8/9/21

anh ơi em dùng in tự động thì lại bị lỗi như này...sử lý sao ạ anh

Bài đã được tự động gộp: 8/9/21

file:///C:/Users/Kien/Desktop/Untitled.png

Hàm cài đặt và bổ trợ	Kiểu	Chức năng
fit_Padding(Height)	Số	Tăng chiều cao thêm một số
fit_defaultHeight(Height)	Số	Chiều cao mặc định nếu giá trị rỗng, dễ hiểu, nếu co giãn vùng ô A1:C20, mà cả vùng đó rỗng, thì chỉnh về chiều cao mặc định.
fit_HeightOfRowNull(Height)	Số	Đặt chiều cao mặc định cho cả dòng rỗng (giãn vùng A1:Z20, dòng A2:Z2 rỗng)
fit_AllSheets()	Có	Giãn dòng kể cả vùng ở trang tính không hiện hành.
fit_Auto()	Có	Bật tự động Fit khi ô tham chiếu thay đổi giá trị Vì hàm FITROW có thể chạy bất kỳ khi nào gây tốn kém, mất thời gian khi các hàm nhạy như ToDay, Now, Rand, RandBetween, ... nằm cùng trang tính. Nên cần hàm bổ trợ này.
fit_Tables(table, ....)	Vùng ô	Nhập một vùng dữ liệu kiểu bảng để tiết kiệm thời gian giãn dòng
fit_Indexes(cell1,cell2,...)	Vùng chứa nhóm văn bản	Căn chỉnh biên bản ở chế độ PrintView, khi giãn dòng, chiều cao trang in có thể cao hơn hoặc thấp hơn, làm cho trang in bị xê dịch, nên cần điều chỉnh để phù hợp.
fit_Scale(scaleWidth,scaleHeight,indentWidth)	Đặt tỉ lệ giãn chiều rộng, chiều cao và thụt đầu dòng, khi chiều cao dòng vượt giới hạn	Vì khi giãn dòng, sẽ có sai số độ lệch nhất định nên cần đặt thông số này. Thông số tỉ lệ chiều rộng và cao quyết định độ chính xác khi giãn dòng. Cho ô chiều cao vượt giới hạn. Và ô gộp có nhiều cột. Ví dụ: Đặt ScaleWidth = 0.0245 hiểu là tăng độ rộng ban đầu 1 * 0.0245 để thực hiện fit. Đặt ScaleHeight = 0.0145 hiểu là tăng thêm chiều cao sau khi fit là 1 * 0.0145 để đặt cho dòng.

HÀM	Chức năng
=FITROW_AddFX()	Tạo nhanh biểu thức FITROW vào ô
=FITROW_AddFXPrintArea()	Tạo nhanh biểu thức FITROW vùng in vào ô, nếu đang ở trang tính đã đặt vùng in
=FITROW_AddButton()	Tạo nút nhấn để giãn dòng
=FITROW_AddButtonPrintArea()	Tạo nút nhấn để giãn dòng vùng in, nếu đang ở trang tính đã đặt vùng in
=FitRow_Off()	Tắt chế độ tự động giãn dòng
=FitRow_On()	Bật chế độ tự động giãn dòng

HÀM FITROW - Co giãn dòng tự động tối ưu nhất cho Excel v2.44 (*28/12/2024)

File đính kèm

HeSanbi

NHG

monkeyit

quyenpv

HeSanbi

monkeyit

HeSanbi

phuongnam366377

HeSanbi

HeSanbi

HeSanbi

quanglenb

HeSanbi

quanglenb

quangpv328

HeSanbi

Mr.hieudoanxd

vova2209

vova2209

0983799078nxk

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

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

Đếm ngược thời gian