Sub text()
Dim Tmr As Double
Tmr = Timer()
FixRowFormat Range("A1:Z72") ' chinh noi dung trong pham vi vung A1:Z72
MsgBox Timer() - Tmr
End Sub
Sub FixRowFormat(ByVal Rn As Range)
Dim xSCR As Boolean, xCAL As Integer, xDIS As Boolean, xENA As Boolean
xSCR = Application.ScreenUpdating: Application.ScreenUpdating = False
xCAL = Application.Calculation: Application.Calculation = xlManual
xDIS = Application.DisplayAlerts: Application.DisplayAlerts = False
xENA = Application.EnableEvents: Application.EnableEvents = False
With Rn.Worksheet
With .Range("AA13") 'lay noi dung mau chu va mau nen tai o AA13 (o mau) de tim va chinh cac o co dinh dang tuong tu
MauChu = .Font.Color
MauNen = .Interior.Color
ChonO MauChu, MauNen, Rn
End With
End With
Application.ScreenUpdating = xSCR: Application.Calculation = xCAL
Application.DisplayAlerts = xDIS: Application.EnableEvents = xENA
End Sub
Sub ChonO(Optional ByVal MauChu As Long = 0, Optional ByVal MauNen As Long = 16777215, Optional Vung As Range)
Dim Rngtxt As String
Dim FirstAddress As String
Dim LastCell As Range
Dim Arr As Variant
If MauChu = 0 And MauNen = 16777215 Then Exit Sub
If Vung Is Nothing Then Set Vung = Selection
'Vung.Select
Set LastCell = Vung.Cells(Vung.Cells.Count)
Application.FindFormat.Clear
Application.FindFormat.Font.Color = MauChu
Application.FindFormat.Interior.Color = MauNen
Do
Rep:
Set LastCell = Vung.Find(What:="", After:=LastCell, LookIn:=xlValues, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=True)
Rngtxt = Rngtxt & "," & LastCell.Address
If Len(FirstAddress) = 0 Then
FirstAddress = LastCell.Address
GoTo Rep
End If
Loop While FirstAddress <> LastCell.Address
Rngtxt = Mid(Rngtxt, 2, Len(Rngtxt) - Len(FirstAddress) - 2)
Arr = Split(Rngtxt, ",")
For MauChu = LBound(Arr) To UBound(Arr)
MergeCellFit Vung.Worksheet.Range(Arr(MauChu))
Next MauChu
'Range(Rngtxt).Select
End Sub
'https://www.giaiphapexcel.com/diendan/threads/t%E1%BA%B7ng-c%C3%A1c-b%E1%BA%A1n-code-autofit-row-v%E1%BB%9Bi-merge-cells-nhi%E1%BB%81u-h%C3%A0ng-nhi%E1%BB%81u-c%E1%BB%99t.105954/#post-681822
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
Dim xSCR As Boolean, xCAL As Integer, xDIS As Boolean, xENA As Boolean
xSCR = Application.ScreenUpdating: Application.ScreenUpdating = False
xCAL = Application.Calculation: Application.Calculation = xlManual
xDIS = Application.DisplayAlerts: Application.DisplayAlerts = False
xENA = Application.EnableEvents: Application.EnableEvents = False
'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.ScreenUpdating = xSCR: Application.Calculation = xCAL
Application.DisplayAlerts = xDIS: Application.EnableEvents = xENA
'Application.Calculation = xlCalculationAutomatic
'Application.EnableEvents = True
'Application.ScreenUpdating = True
End Sub
