Giúp code chỉnh độ rộng dòng theo ký tự trong ô

[minhtuan55]

Chào cả nhà GPE !
Em cần 1 đoạn code để chỉnh độ rộng dòng theo tổng ký tự trong ô
Ví dụ vùng cần chỉnh độ rộng: B6:B100
- Nếu ô đó có tổng ký tự >= 15 thì độ rộng 30 Pixel
- Còn tất cả trường hợp còn lại ( tổng ký tự < 15, ô trống, ô báo lỗi NA, Lồi NS....) thì độ rộng 15 Pixel

Mục đích làm: Em thường xuyên in báo cáo, do các tên hàng nó dài nên em muốn nó tự động xuống dòng đúng Chính xác do em quy định

Em đã tự viết code sau mà nó báo lỗi chẳng biết sao

 Sub GPE()
Dim Cll As Range
For Each Cll In Range("B6:B25").Value
    If Len(Cll) >= 10 Then
       Cll.RowHeight = 14
    Else
       Cll.RowHeight = 30
    End If
    
Next Cll
End Sub

Xin chân thành cảm ơn !

 

[huuthang_bd]

Chữ I mà dài bằng chữ W là sai từ lúc đặt vấn đề rồi.

 

[HieuCD]

Bác xem giúp mình những dòng highlight màu vàng nhé, và bác xem giúp e nếu dòng STT 67 nếu cột B chữ bị cho xuống dòng, những vì cột C dòng đó không lớn 88 ký tự sẽ bị chuyển về dòng đó độ rộng 15 và cột B sẽ bị mất chữ

Thử code, nhớ xem ghi chú

Sub GPE()
  Dim Sh As Worksheet, i As Long, eR As Long
  Application.ScreenUpdating = False
  For Each Sh In Sheets
    eR = Sh.Range("C65500").End(xlUp).Row
    Sh.Rows("1:" & eR).EntireRow.AutoFit
    Sh.Range("A1:C" & eR).VerticalAlignment = xlCenter
    ' Neu thay khong dep thì chay 3 dòng lenh duoi, toc do se rat cham
    'For i = 1 To eR
      'Sh.Rows(i).RowHeight = Sh.Rows(i).RowHeight + 0.6
    'Next i
  Next Sh
  Application.ScreenUpdating = True
End Sub

 

[KhanhChi29]

Thử code, nhớ xem ghi chú

Sub GPE()
  Dim Sh As Worksheet, i As Long, eR As Long
  Application.ScreenUpdating = False
  For Each Sh In Sheets
    eR = Sh.Range("C65500").End(xlUp).Row
    Sh.Rows("1:" & eR).EntireRow.AutoFit
    Sh.Range("A1:C" & eR).VerticalAlignment = xlCenter
    ' Neu thay khong dep thì chay 3 dòng lenh duoi, toc do se rat cham
    'For i = 1 To eR
      'Sh.Rows(i).RowHeight = Sh.Rows(i).RowHeight + 0.6
    'Next i
  Next Sh
  Application.ScreenUpdating = True
End Sub

Code này chạy được nhưng khi chạy thêm 3 dòng dưới tốc độ chậm quá, bạn và mọi người cải thiện tốc độ lại với;
Nhờ mọi người tạm sửa cho code trên chỉ áp dụng cho sheet hiện hành thôi, Do cấu trúc của các Sheet có thể khác nhau
Em đã sửa chỉ cho áp dụng cho sheet hiện hành nhưng vẫn chậm
Sub GPE()
Dim i As Long, eR As Long
Application.ScreenUpdating = False
eR = ActiveSheet.Range("C65500").End(xlUp).Row
ActiveSheet.Rows("7:" & eR).EntireRow.AutoFit
ActiveSheet.Range("A7:C" & eR).VerticalAlignment = xlCenter
ActiveSheet.Range("A7:C" & eR).WrapText = True
' Neu thay khong dep thì chay 3 dòng lenh duoi, toc do se rat cham
For i = 7 To eR
ActiveSheet.Rows(i).RowHeight = ActiveSheet.Rows(i).RowHeight + 5.5
Next i
Application.ScreenUpdating = True
End Sub

 

[HieuCD]

Code này chạy được nhưng khi chạy thêm 3 dòng dưới tốc độ chậm quá, bạn và mọi người cải thiện tốc độ lại với;
Nhờ mọi người tạm sửa cho code trên chỉ áp dụng cho sheet hiện hành thôi, Do cấu trúc của các Sheet có thể khác nhau
Em đã sửa chỉ cho áp dụng cho sheet hiện hành nhưng vẫn chậm
Sub GPE()
Dim i As Long, eR As Long
Application.ScreenUpdating = False
eR = ActiveSheet.Range("C65500").End(xlUp).Row
ActiveSheet.Rows("7:" & eR).EntireRow.AutoFit
ActiveSheet.Range("A7:C" & eR).VerticalAlignment = xlCenter
ActiveSheet.Range("A7:C" & eR).WrapText = True
' Neu thay khong dep thì chay 3 dòng lenh duoi, toc do se rat cham
For i = 7 To eR
ActiveSheet.Rows(i).RowHeight = ActiveSheet.Rows(i).RowHeight + 5.5
Next i
Application.ScreenUpdating = True
End Sub

Có file thực mới có cách xử lý phù hợp

 

[KhanhChi29]

Có file thực mới có cách xử lý phù hợp

Em thử chạy code cho 1 sheet đầu mất khoảng 5 phút. Anh xem có cách nào tối ưu code giúp em với

 

[HieuCD]

Em thử chạy code cho 1 sheet đầu mất khoảng 5 phút. Anh xem có cách nào tối ưu code giúp em với

code gốc, máy mình chạy 0.4 giây
Code mới nhanh hơn (hên xui)

Sub GPE()
  Dim i As Long, eR As Long, Rng As Range, S As Variant, iKey

  Application.ScreenUpdating = False
  Application.Calculation = xlManual
  eR = ActiveSheet.Range("C65500").End(xlUp).Row
  ActiveSheet.Range("A6:C" & eR).WrapText = True
  ActiveSheet.Rows("6:" & eR).EntireRow.AutoFit
  ActiveSheet.Range("A6:C" & eR).VerticalAlignment = xlCenter   

  With CreateObject("scripting.dictionary")
    For i = 6 To eR
      iKey = ActiveSheet.Rows(i).RowHeight + 8.5
      If .exists(iKey) = False Then
        .Add iKey, Array(i)
      Else
        S = .Item(iKey)
        ReDim Preserve S(UBound(S)+1)
        S(UBound(S)) = i
        .Item(iKey) = S
      End If
    Next i
    For Each iKey In .keys
      S = .Item(iKey)
      For i = 0 To UBound(S)
        If Rng Is Nothing Then
          Set Rng = ActiveSheet.Range("A" & S(i))
        Else
          Set Rng = Union(Rng, ActiveSheet.Range("A" & S(i)))
        End If
      Next i
      Rng.RowHeight = iKey
      Set Rng = Nothing
    Next
  End With
  Application.Calculation = xlAutomatic
  Application.ScreenUpdating = True
End Sub

 

[KhanhChi29]

code gốc, máy mình chạy 0.4 giây
Code mới nhanh hơn (hên xui)

Sub GPE()
  Dim i As Long, eR As Long, Rng As Range, S As Variant, iKey

  Application.ScreenUpdating = False
  Application.Calculation = xlManual
  eR = ActiveSheet.Range("C65500").End(xlUp).Row
  ActiveSheet.Range("A6:C" & eR).WrapText = True
  ActiveSheet.Rows("6:" & eR).EntireRow.AutoFit
  ActiveSheet.Range("A6:C" & eR).VerticalAlignment = xlCenter  

  With CreateObject("scripting.dictionary")
    For i = 6 To eR
      iKey = ActiveSheet.Rows(i).RowHeight + 8.5
      If .exists(iKey) = False Then
        .Add iKey, Array(i)
      Else
        S = .Item(iKey)
        ReDim Preserve S(UBound(S)+1)
        S(UBound(S)) = i
        .Item(iKey) = S
      End If
    Next i
    For Each iKey In .keys
      S = .Item(iKey)
      For i = 0 To UBound(S)
        If Rng Is Nothing Then
          Set Rng = ActiveSheet.Range("A" & S(i))
        Else
          Set Rng = Union(Rng, ActiveSheet.Range("A" & S(i)))
        End If
      Next i
      Rng.RowHeight = iKey
      Set Rng = Nothing
    Next
  End With
  Application.Calculation = xlAutomatic
  Application.ScreenUpdating = True
End Sub

Máy anh khỏe quá, 0.4 giây đã xong
Chạy code sau nhanh hơn. Hôm tới anh em gặp nhau nhé. Đầu tháng 7 nhé

 

[Phan Thế Hiệp]

Máy anh khỏe quá

Dĩ nhiên!
Nhưng cũng còn tùy lúc!

Khà khà khà

 

[HeSanbi]

Em thử chạy code cho 1 sheet đầu mất khoảng 5 phút. Anh xem có cách nào tối ưu code giúp em với

Tôi giúp bạn tối ưu Code, Cách viết code thao tác trực tiếp Worksheet là không nên

Code của bạn sau khi tối ưu tôi Run cũng chỉ mất 0.5(s)

Lưu ý: Application.ScreenUpdating sẽ không phù hợp với trường hợp Ứng dụng của bạn chạy Runtime nhé.
Thay vào đó hãy sử dụng DoEvents

Sub GPE()
'DoEvents
  Dim T As Double: T = Timer
  Application.ScreenUpdating = False
  Dim i&, eR&, Rng As Range
  With ThisWorkbook.Worksheets(1)
    eR = .Cells(Rows.Count, 3).End(xlUp).Row
    Set Rng = .Range("A6:C" & eR)
    With Rng
      .EntireRow.AutoFit
      .VerticalAlignment = xlCenter
      .WrapText = True
    End With
    For i = 6 To eR
      .Rows(i).RowHeight = .Rows(i).RowHeight + 8.5
    Next i
  End With
  Application.ScreenUpdating = True
  Debug.Print Round(Timer - T, 2)
  Set Rng = Nothing
End Sub