Anh chị giúp xem lỗi Co dãn dòng dòng

[vova2209]

Chào anh chị! em dùng code co dãn dòng ở diễn đàn!
- Khi thay đổi giá trị ở ô AZ1 thì code sẽ hoạt động
- Anh Chị xem giúp em lỗi sử lý như nào. 1 vài trường hợp như hình 1 không dãn ra hết, bị xuống dòng mất chữ.
- File đính kèm bên dưới. anh chị xem giúp em. em cảm ơn!

 

[befaint]

mất chữ

Khi in ra có bị mất chữ không bạn?

 

[vova2209]

Khi in ra có bị mất chữ không bạn?

In ra bị đúng như hình trên cùng, bị mất chữ. nếu chữ dài hơn khi xuống dòng thì vẫn giãn đủ, chỉ bị mất chữ trong trường hợp có 1 chữ xuống dòng dưới. em để chế độ wiew 100% vẫn không được.

 

[le_vis]

In ra bị đúng như hình trên cùng, bị mất chữ. nếu chữ dài hơn khi xuống dòng thì vẫn giãn đủ, chỉ bị mất chữ trong trường hợp có 1 chữ xuống dòng dưới. em để chế độ wiew 100% vẫn không được.

Bạn thử thay bằng đoạn code này xem

Sub AuTo_dong()
Dim MergeWidth As Single, oWidth As Double, NewRowHt As Double
Dim subRng As Range, AutoFitRng As Range, Cll As Range, Rng As Range
Application.ScreenUpdating = False
Set Rng = Range("F7:R11") ''''' Dùng khi có Mengel các ô cùng dòng
For Each Cll In Rng
If Cll <> "" And Cll.MergeCells Then
Set AutoFitRng = Cll.MergeArea
With AutoFitRng
.MergeCells = False
oWidth = .Cells(1).ColumnWidth
MergeWidth = 0
For Each subRng In AutoFitRng
MergeWidth = subRng.ColumnWidth + MergeWidth
Next
MergeWidth = MergeWidth + AutoFitRng.Cells.Count * 0.75
.Cells(1).ColumnWidth = MergeWidth
Cll.WrapText = True
.EntireRow.AutoFit
NewRowHt = .RowHeight
.Cells(1).ColumnWidth = oWidth
.MergeCells = True
.RowHeight = NewRowHt
End With
End If
Next
Application.ScreenUpdating = True
End Sub

 

[vova2209]

Bạn thử thay bằng đoạn code này xem

Sub AuTo_dong()
Dim MergeWidth As Single, oWidth As Double, NewRowHt As Double
Dim subRng As Range, AutoFitRng As Range, Cll As Range, Rng As Range
Application.ScreenUpdating = False
Set Rng = Range("F7:R11") ''''' Dùng khi có Mengel các ô cùng dòng
For Each Cll In Rng
If Cll <> "" And Cll.MergeCells Then
Set AutoFitRng = Cll.MergeArea
With AutoFitRng
.MergeCells = False
oWidth = .Cells(1).ColumnWidth
MergeWidth = 0
For Each subRng In AutoFitRng
MergeWidth = subRng.ColumnWidth + MergeWidth
Next
MergeWidth = MergeWidth + AutoFitRng.Cells.Count * 0.75
.Cells(1).ColumnWidth = MergeWidth
Cll.WrapText = True
.EntireRow.AutoFit
NewRowHt = .RowHeight
.Cells(1).ColumnWidth = oWidth
.MergeCells = True
.RowHeight = NewRowHt
End With
End If
Next
Application.ScreenUpdating = True
End Sub

Vẫn bị mất chữ bạn ạ! bạn add code thử vào file chạy mà xem. giúp mình cách khác xem được không?

 

[le_vis]

Vẫn bị mất chữ bạn ạ! bạn add code thử vào file chạy mà xem. giúp mình cách khác xem được không?
View attachment 268726

Xem File đính kèm nhé

 

[selves037]

Xem File đính kèm nhé

nhân tiện giúp trường hợp bài đăng của mình luôn với b ơi, có cùng lỗi như trên

 

[le_vis]

nhân tiện giúp trường hợp bài đăng của mình luôn với b ơi, có cùng lỗi như trên

Bài của bạn ở đâu ???

 

[vova2209]

mình đã sử lý được rồi nhé! gửi bạn code

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

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.85
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 * 1.15 'Chiêu` cao dòng khi fix sang 2 dòng
.RowHeight = FirstCellHeight
End With
ExitSub:
End Sub

 

[Mutants Men]

mình đã sử lý được rồi nhé! gửi bạn code

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

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.85
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 * 1.15 'Chiêu` cao dòng khi fix sang 2 dòng
.RowHeight = FirstCellHeight
End With
ExitSub:
End Sub

bạn cho mình hỏi bạn có thử với dữ liệu dài chưa? sau khi chạy thì nó bị như vầy! bạn giúp mình với! mình cũng đang cần cái như vầy!

 

[vova2209]

bạn cho mình hỏi bạn có thử với dữ liệu dài chưa? sau khi chạy thì nó bị như vầy! bạn giúp mình với! mình cũng đang cần cái như vầy!View attachment 270471

được bạn! code đấy. mình dùng thấy ổn