Code tự co dãn dòng không chạy. Nhờ các bạn sửa giúp (1 người xem)

[le_vis]

Xin các bạn xem file đính kèm - Trân trọng cảm ơn

 

[vanaccex]

Bạn thử với sub này xem mình thử với 1 sub MergeCellFit trên diễn đàn !

Sub Autofit_dong()
    MergeCellFit Range("D9")
End Sub

Sub MergeCellFit(ByVal MergeCells As Range)
    Dim Diff As Single
    Dim FirstCell As Range, MergeCellArea As Range
    Dim Col As Long, ColCount As Long, RowCount As Long
    Dim FirstCellWidth As Double, FirstCellHeight As Double, MergeCellWidth As Double
    If MergeCells.Count = 1 Then
        Set MergeCellArea = MergeCells.MergeArea
    Else
        Set MergeCellArea = MergeCells
    End If
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    With MergeCellArea
        ColCount = .Columns.Count
        RowCount = .Rows.Count
        .WrapText = True
        If RowCount = 1 And ColCount = 1 Then
            .EntireRow.AutoFit
            GoTo ExitSub
        End If
        Set FirstCell = .Cells(1, 1)
        FirstCellWidth = FirstCell.ColumnWidth
        Diff = 0.75
        For Col = 1 To ColCount
            MergeCellWidth = MergeCellWidth + .Cells(1, Col).ColumnWidth + Diff
        Next
        .MergeCells = False
        FirstCell.ColumnWidth = MergeCellWidth - Diff
        .EntireRow.AutoFit
        FirstCellHeight = FirstCell.RowHeight
        .MergeCells = True
        FirstCell.ColumnWidth = FirstCellWidth
        FirstCellHeight = FirstCellHeight / RowCount
        .RowHeight = FirstCellHeight
    End With
ExitSub:
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

[le_vis]

Bạn thử với sub này xem mình thử với 1 sub MergeCellFit trên diễn đàn !

Sub Autofit_dong()
    MergeCellFit Range("D9")
End Sub

Sub MergeCellFit(ByVal MergeCells As Range)
    Dim Diff As Single
    Dim FirstCell As Range, MergeCellArea As Range
    Dim Col As Long, ColCount As Long, RowCount As Long
    Dim FirstCellWidth As Double, FirstCellHeight As Double, MergeCellWidth As Double
    If MergeCells.Count = 1 Then
        Set MergeCellArea = MergeCells.MergeArea
    Else
        Set MergeCellArea = MergeCells
    End If
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    With MergeCellArea
        ColCount = .Columns.Count
        RowCount = .Rows.Count
        .WrapText = True
        If RowCount = 1 And ColCount = 1 Then
            .EntireRow.AutoFit
            GoTo ExitSub
        End If
        Set FirstCell = .Cells(1, 1)
        FirstCellWidth = FirstCell.ColumnWidth
        Diff = 0.75
        For Col = 1 To ColCount
            MergeCellWidth = MergeCellWidth + .Cells(1, Col).ColumnWidth + Diff
        Next
        .MergeCells = False
        FirstCell.ColumnWidth = MergeCellWidth - Diff
        .EntireRow.AutoFit
        FirstCellHeight = FirstCell.RowHeight
        .MergeCells = True
        FirstCell.ColumnWidth = FirstCellWidth
        FirstCellHeight = FirstCellHeight / RowCount
        .RowHeight = FirstCellHeight
    End With
ExitSub:
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Cảm ơn bạn. Ý mình là code đảm bảo tự động co dãn được tất cả các dòng đã MergeCells trong Sheet theo điều kiện là số lượng ký tự nhiều hay ít . bạn xem lại giúp nhé

 

[Nhất Chi Lan]

Cảm ơn bạn. Ý mình là code đảm bảo tự động co dãn được tất cả các dòng đã MergeCells trong Sheet theo điều kiện là số lượng ký tự nhiều hay ít . bạn xem lại giúp nhé

Cả cái trang tính nó rộng bao la vậy mà chạy Code thì máy treo mất ạ
Anh thử cách khoanh vùng lại xem sao

Sub Autofit_dong()
    Dim Rng As Range, Cll As Range
Set Rng = Range("D7", Range("D" & Rows.Count).End(xlUp))
For Each Cll In Rng
    If Cll.MergeCells = True Then
        If Cll <> Empty Then MergeCellFit Cll
    End If
Next
End Sub

 

[le_vis]

Cả cái trang tính nó rộng bao la vậy mà chạy Code thì máy treo mất ạ
Anh thử cách khoanh vùng lại xem sao

Sub Autofit_dong()
    Dim Rng As Range, Cll As Range
Set Rng = Range("D7", Range("D" & Rows.Count).End(xlUp))
For Each Cll In Rng
    If Cll.MergeCells = True Then
        If Cll <> Empty Then MergeCellFit Cll
    End If
Next
End Sub

Xin cảm ơn bạn đã quan tâm - Mình chạy lỗi dòng code này bạn ơi
If Cll <> Empty Then MergeCellFit Cll
Có thể khống chế từ D7 đến G200 cũng được bạn ạ

 

[Nhất Chi Lan]

Xin cảm ơn bạn đã quan tâm - Mình chạy lỗi dòng code này bạn ơi
If Cll <> Empty Then MergeCellFit Cll
Có thể khống chế từ D7 đến G200 cũng được bạn ạ

Anh đã Copy cái Sub MergeCellFit vào file chưa

 

[le_vis]

Anh đã Copy cái Sub MergeCellFit vào file chưa

Tôi đã copi toàn bộ code này rồi
Sub Autofit_dong()
Dim Rng As Range, Cll As Range
Set Rng = Range("D7", Range("D" & Rows.Count).End(xlUp))
For Each Cll In Rng
If Cll.MergeCells = True Then
If Cll <> Empty Then MergeCellFit Cll
End If
Next
End Sub

Và sub này vào File rồi
Sub Autofit_dong()
MergeCellFit Range("D7")
End Sub

Bạn xem lại giúp

 

[Nhất Chi Lan]

Tôi đã copi toàn bộ code này rồi
Sub Autofit_dong()
Dim Rng As Range, Cll As Range
Set Rng = Range("D7", Range("D" & Rows.Count).End(xlUp))
For Each Cll In Rng
If Cll.MergeCells = True Then
If Cll <> Empty Then MergeCellFit Cll
End If
Next
End Sub

Và sub này vào File rồi
Sub Autofit_dong()
MergeCellFit Range("D7")
End Sub

Bạn xem lại giúp

Anh xem file thử

 

[le_vis]

Anh xem file thử

Cảm ơn bạn - Xin cảm ơn