Đăng nhập/Đăng ký mở rộng
Sub AutoFitMergedCellRowHeight()
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
Dim iX As Integer
ActiveCell.WrapText = True
If ActiveCell.MergeCells Then
With ActiveCell.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
ActiveCellWidth = ActiveCell.ColumnWidth
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth + _
MergedCellRgWidth
iX = iX + 1
Next
MergedCellRgWidth = MergedCellRgWidth + (iX - 1) * 0.71
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
End If
End With
End If
End Sub
vanhien120790 gửi lúc 7/8/2014 21:07
Hi anh!
Mình có cách nào chọn tất cả các ô bị ô đã MERGE không anh .Giờ em có 10 ô ...
Sub AutoFitMerge()
Dim sDiachi As String
Range("A1").Select
sDiachi = Selection.SpecialCells(xlCellTypeLastCell).Address
sDiachi = Replace(sDiachi , "$", "")
Range("A1:" & sDiachi).Select
For Each rCell In Selection
If rCell.MergeCells Then
AutoFitMergedCellRowHeight
End If
Next
Range("A1").Select
End Sub
vanhien120790 gửi lúc 11/8/2014 09:05
Cám ơn chú, nhưng con chạy nó bị như thế này. Là bị lỗi gì chú. Cám ơn chú
Private Sub Worksheet_Change(ByVal Target As Range)
Dim NewRwH As Single
Dim cWd As Single, MrgeWd As Single
Dim c As Object, cc As Object
Dim ma As Object
Application.ScreenUpdating = False
With Target
If .MergeCells And .WrapText Then
cWd = .ColumnWidth
Set ma = .MergeArea
For Each cc In ma.Cells
MrgeWd = MrgeWd + cc.ColumnWidth
Next
ma.MergeCells = False
.ColumnWidth = MrgeWd
.EntireRow.AutoFit
NewRwH = .RowHeight
With ma
.MergeCells = True
.RowHeight = NewRwH
End With
End If
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Application.ScreenUpdating = True
End Sub
KHOI LUONG HOAN THANH MAI TON.xlsm
202.83 KB, Lượt tải về: 8251
vanhien120790 gửi lúc 13/8/2014 10:50
Đây là file của em đây các anh ạ. Em chưa làm được. Em cần 1 lệnh Wrap text được t ...
Sub AutoFitMerge()
Dim lDong As Long
Dim i As Integer
Dim sCelldau As String
Dim rCell As Range
Dim NewRwH As Single, cWd As Single, MrgeWd As Single
With Application
.ScreenUpdating = False 'Tam dung cap nhat man hinh
.Calculation = xlCalculationManual 'Tat cap nhat tinh toan
.EnableEvents = False
.DisplayAlerts = False
.Cursor = xlWait
.EnableCancelKey = xlErrorHandler
End With
lDong = ActiveCell.Row + Selection.Rows.Count
sCelldau = ActiveCell.Address
ActiveCell.Select
Do Until ActiveCell.Row = lDong
If ActiveCell.MergeCells Then
With ActiveCell
.WrapText = True
If i = 0 Then
'Lay ColumnWidth cua cell dau va Tinh Tong ColumnWidth
For Each rCell In Selection
i = i + 1
'Lay ColumnWidth cua cell dau
If i = 1 Then cWd = rCell.ColumnWidth
'Tinh Tong ColumnWidth
MrgeWd = MrgeWd + rCell.ColumnWidth
Next
End If
Selection.MergeCells = False
.ColumnWidth = MrgeWd
.EntireRow.AutoFit
NewRwH = .RowHeight
'Tra lai ColumnWidth cua cell dau
.ColumnWidth = cWd
'MergeCells va lay Chieu cao Dong
With Selection
.MergeCells = True
.RowHeight = NewRwH
End With
End With
End If
ActiveCell.Offset(1).Select
Loop
With Application
.ScreenUpdating = True 'Cap nhat man hinh
.Calculation = xlCalculationAutomatic 'Cap nhat tinh toan
.EnableEvents = True
.DisplayAlerts = True
.Cursor = xlDefault
.EnableCancelKey = xlInterrupt
End With
Range(sCelldau).Select
End Sub
KHOI LUONG HOAN THANH MAI TON 2.xlsm
(202.6 KB, Lượt tải về: 8889)
26" thì Ô B12 sẽ không được AutoFit
