Xin giúp đỡ sửa mã AutoFit chiều cao dòng theo điều kiện!

[theanhst92]

Kính gửi mọi người trên diễn đàn ạ!
Em có tham khảo trên diễn đàn để chạy autofit cho dòng đã được wraptext nhưng vẫn chưa biết làm theo điều kiện.
Điều kiện là tại cột chứa dữ liệu đã được wraptext thì khi kích thước chiều cao dòng sau khi autofit nhỏ 20 thì dòng đó bằng 20 còn nếu như chiều cao dòng sau khi autofit lơn hơn 20 thì bỏ qua.
lệnh sẽ được chạy lần lượt từ dòng đầu đến dòng cuối cùng chứa dữ liệu của cột đó. mong mọi người giúp đỡ em với ạ!

 

[Maika8008]

Kính gửi mọi người trên diễn đàn ạ!
Em có tham khảo trên diễn đàn để chạy autofit cho dòng đã được wraptext nhưng vẫn chưa biết làm theo điều kiện.
Điều kiện là tại cột chứa dữ liệu đã được wraptext thì khi kích thước chiều cao dòng sau khi autofit nhỏ 20 thì dòng đó bằng 20 còn nếu như chiều cao dòng sau khi autofit lơn hơn 20 thì bỏ qua.
lệnh sẽ được chạy lần lượt từ dòng đầu đến dòng cuối cùng chứa dữ liệu của cột đó. mong mọi người giúp đỡ em với ạ!
View attachment 253639

Dùng đoạn code này với lưu ý là phải chạy vòng lặp chỉnh chiều cao cho từng cell trong myrange bạn nhé!

Sub Autofit_test()
Dim myRange As Range, Cll As Range, lr As Long

     With Sheet1
        lr = .Range("B" & .Rows.Count).End(xlUp).Row
        Set myRange = .Range("B4:B" & lr)
     End With
       
        myRange.EntireRow.autofit
   
    For Each Cll In myRange
        If Cll.RowHeight < 20 Then
            Cll.RowHeight = 20
        End If
    Next

End Sub

 

[theanhst92]

Dùng đoạn code này với lưu ý là phải chạy vòng lặp chỉnh chiều cao cho từng cell trong myrange bạn nhé!

Sub Autofit_test()
Dim myRange As Range, Cll As Range, lr As Long

     With Sheet1
        lr = .Range("B" & .Rows.Count).End(xlUp).Row
        Set myRange = .Range("B4:B" & lr)
     End With
     
        myRange.EntireRow.autofit
 
    For Each Cll In myRange
        If Cll.RowHeight < 20 Then
            Cll.RowHeight = 20
        End If
    Next

End Sub

Dùng vòng lặp đã chạy được nhưng tốc độ với hơn 10000 dòng thì rất là chậm bác ạ. không biết có phương án nào khả thi không ạ!

 

[huuthang_bd]

Cách không sửa code có được không bạn?

 

[Maika8008]

Dùng vòng lặp đã chạy được nhưng tốc độ với hơn 10000 dòng thì rất là chậm bác ạ. không biết có phương án nào khả thi không ạ!

Tôi không biết có giải pháp nào khả dĩ không. Chờ các thành viên khác vậy.

 

[Nhattanktnn]

.

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

Dùng vòng lặp đã chạy được nhưng tốc độ với hơn 10000 dòng thì rất là chậm bác ạ. không biết có phương án nào khả thi không ạ!

Sửa chút bé xíu thôi là khác ngay:

Sub Autofit_test()
Dim myRange As Range, Cll As Range, lr As Long, iRng As Range

     With Sheet1
        lr = .Range("B" & .Rows.Count).End(xlUp).Row
        Set myRange = .Range("B4:B" & lr)
     End With
    
        myRange.EntireRow.autofit
 
    For Each Cll In myRange
        If Cll.RowHeight < 20 Then
            If iRng Is Nothing Then
                Set iRng = Cll
            Else
                Set iRng = Union(iRng, Cll)
            End If
        End If
    Next
iRng.EntireRow.RowHeight = 20
End Sub

 

[Maika8008]

.

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

Sửa chút bé xíu thôi là khác ngay:

Sub Autofit_test()
Dim myRange As Range, Cll As Range, lr As Long, iRng As Range

     With Sheet1
        lr = .Range("B" & .Rows.Count).End(xlUp).Row
        Set myRange = .Range("B4:B" & lr)
     End With
   
        myRange.EntireRow.autofit

    For Each Cll In myRange
        If Cll.RowHeight < 20 Then
            If iRng Is Nothing Then
                Set iRng = Cll
            Else
                Set iRng = Union(iRng, Cll)
            End If
        End If
    Next
iRng.EntireRow.RowHeight = 20
End Sub

À! Có cách Union range mà quên mất. Tôi sẽ nhớ mãi vụ này, cảm ơn bạn!

 

[theanhst92]

.

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

Sửa chút bé xíu thôi là khác ngay:

Sub Autofit_test()
Dim myRange As Range, Cll As Range, lr As Long, iRng As Range

     With Sheet1
        lr = .Range("B" & .Rows.Count).End(xlUp).Row
        Set myRange = .Range("B4:B" & lr)
     End With
   
        myRange.EntireRow.autofit

    For Each Cll In myRange
        If Cll.RowHeight < 20 Then
            If iRng Is Nothing Then
                Set iRng = Cll
            Else
                Set iRng = Union(iRng, Cll)
            End If
        End If
    Next
iRng.EntireRow.RowHeight = 20
End Sub

Em xin cảm ơn mọi người đã giúp đỡ em ạ!