Nhờ giúp sửa code co giãn dòng tự động

le_vis · 15/2/19

Tôi có dùng đoạn code (Lâu không nhớ của ai); Nay sử dụng vào File thấy chạy chậm quá – Đồng thời cần tùy biến thêm 2 trường hợp nữa mà ngẫm mãi không được – Nhờ các bạn giúp đỡ - Xin cảm ơn !

VetMini · 15/2/19

Tam đọn lựng (theo a rít tốt):
Tiền đề: cái gì có liên quan đến mẫu mã thì chậm.
Thực trạng: co dãn dòng liên quan đến mẫu mã.
Kết luận: co dãn dòng thì chậm.

be_09 · 15/2/19

Thử File.

HieuCD · 15/2/19

le_vis đã viết:
Tôi có dùng đoạn code (Lâu không nhớ của ai); Nay sử dụng vào File thấy chạy chậm quá – Đồng thời cần tùy biến thêm 2 trường hợp nữa mà ngẫm mãi không được – Nhờ các bạn giúp đỡ - Xin cảm ơn !

Chạy Sub

Mã:

Dim Dic As Object, k As Long, iRow As Long
Sub Autofit_dong()
  Dim eRow As Long
  eRow = Range("D" & Rows.Count).End(xlUp).Row
  If eRow > 6 Then
    Application.ScreenUpdating = False
    Set Dic = CreateObject("scripting.dictionary")
    For iRow = 7 To eRow
      MergeRowFit 4, 10 'Cot D toi cot J
    Next iRow
    Set Dic = Nothing
    Application.ScreenUpdating = True
  End If
End Sub

Private Sub MergeRowFit(ByVal fCol As Long, ByVal eCol As Long)
  Dim sh As Worksheet, sRng As Range
  Dim j As Long, col As Long, jk As Long
  Dim sRngWidth As Double, sRngHeight As Double
  Const Diff As Single = 0.75
 
  Set sh = Sheets("Sheet2")
  For j = fCol To eCol
    If Cells(iRow, j).MergeCells = True Then
      Set sRng = Cells(iRow, j).MergeArea
      sRng.WrapText = True
      If Len(Cells(iRow, j).Value) > 0 Then
        sRngWidth = -Diff
        For col = 1 To sRng.Columns.Count
          sRngWidth = sRngWidth + sRng(1, col).ColumnWidth + Diff
        Next
        If Dic.exists(sRngWidth) = False Then
          k = k + 1: Dic.Add sRngWidth, k
          sh.Cells(1, k).ColumnWidth = sRngWidth
          sh.Cells(1, k).WrapText = True
        End If
        jk = Dic.Item(sRngWidth)
        sh.Cells(1, jk) = Cells(iRow, j).Value
      End If
      j = j + sRng.Columns.Count - 1
    End If
  Next j
  sh.Rows("1:1").EntireRow.AutoFit
  sRngHeight = sh.Cells(1, 1).RowHeight
  If k Then sh.Cells(1, 1).Resize(, k).Value = Empty
  sRng.RowHeight = sRngHeight / sRng.Rows.Count
  iRow = iRow + sRng.Rows.Count - 1
End Sub

le_vis · 15/2/19

be09 đã viết:
Thử File.[/QUOTE
Cảm ơn thầy - Rất gọn và chuẩn - Tốc độ

vc_đi chơi · 2/11/19

be09 đã viết:
Thử File.

Em có tham khảo đoạn code Bác viết, rất hay và tốc độ.

Mã:

Option Explicit

Sub CoGianDong_Hai()
Dim Dchinh As Single
Dim DRong As Range
Dim RDong As Range
Dim RCot As Double
Dim DchinhHang As Double
Dim Mang As Variant
Dim i As Integer

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Sheet1

'Thay doi Cell trong Mang cho phù hop
Mang = Array("D11", "D13", "D16", "G17", "D18", "D20", "D21")
    For i = 0 To UBound(Mang)
        On Error Resume Next
        Set RDong = Range(Range(Mang(i)).MergeArea.Address)
        RDong.MergeCells = False
        RCot = RDong.Cells(1).ColumnWidth
        Dchinh = 0
            For Each DRong In RDong
                DRong.WrapText = True
                Dchinh = DRong.ColumnWidth + Dchinh
            Next
        Dchinh = Dchinh + RDong.Cells.Count * 0.1
        RDong.Cells(1).ColumnWidth = Dchinh
        RDong.EntireRow.AutoFit
        DchinhHang = RDong.RowHeight
        RDong.Cells(1).ColumnWidth = RCot
        RDong.MergeCells = True
        RDong.RowHeight = DchinhHang
    Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End With

End Sub

Code trên có tác dung với sheet 1 và tên các ô gộp cần thay đổi chiều cao để bao vừa nội dung trong vùng gộp đó, đó là các ô: "D11", "D13", "D16", "G17", "D18", "D20", "D21".
Anh cho em hỏi thêm vấn đề:
- Giả sử có thêm nhiều sheet nữa : sheet 2, sheet 3.......và trong sheet có những ô đã được gộp và muốn thay đổi chiều cao tự động của các ô đã được gộp đó trong các sheet thì phải chỉnh sửa đoạn code như thế nào để khi chạy code tự động dãn dòng các ô được gộp đó ở trong các sheet.
Xin cảm ơn Bác!

vc_đi chơi · 2/11/19

HieuCD đã viết:

Chạy Sub

Mã:

Dim Dic As Object, k As Long, iRow As Long
Sub Autofit_dong()
  Dim eRow As Long
  eRow = Range("D" & Rows.Count).End(xlUp).Row
  If eRow > 6 Then
    Application.ScreenUpdating = False
    Set Dic = CreateObject("scripting.dictionary")
    For iRow = 7 To eRow
      MergeRowFit 4, 10 'Cot D toi cot J
    Next iRow
    Set Dic = Nothing
    Application.ScreenUpdating = True
  End If
End Sub

Private Sub MergeRowFit(ByVal fCol As Long, ByVal eCol As Long)
  Dim sh As Worksheet, sRng As Range
  Dim j As Long, col As Long, jk As Long
  Dim sRngWidth As Double, sRngHeight As Double
  Const Diff As Single = 0.75

  Set sh = Sheets("Sheet2")
  For j = fCol To eCol
    If Cells(iRow, j).MergeCells = True Then
      Set sRng = Cells(iRow, j).MergeArea
      sRng.WrapText = True
      If Len(Cells(iRow, j).Value) > 0 Then
        sRngWidth = -Diff
        For col = 1 To sRng.Columns.Count
          sRngWidth = sRngWidth + sRng(1, col).ColumnWidth + Diff
        Next
        If Dic.exists(sRngWidth) = False Then
          k = k + 1: Dic.Add sRngWidth, k
          sh.Cells(1, k).ColumnWidth = sRngWidth
          sh.Cells(1, k).WrapText = True
        End If
        jk = Dic.Item(sRngWidth)
        sh.Cells(1, jk) = Cells(iRow, j).Value
      End If
      j = j + sRng.Columns.Count - 1
    End If
  Next j
  sh.Rows("1:1").EntireRow.AutoFit
  sRngHeight = sh.Cells(1, 1).RowHeight
  If k Then sh.Cells(1, 1).Resize(, k).Value = Empty
  sRng.RowHeight = sRngHeight / sRng.Rows.Count
  iRow = iRow + sRng.Rows.Count - 1
End Sub

Anh ơi, nếu cần giãn dòng ở ô được gộp trong nhiều sheet thì chỉnh sửa code ở đoạn nào ạ?

HieuCD · 2/11/19

vc_đi chơi đã viết:
Anh ơi, nếu cần giãn dòng ở ô được gộp trong nhiều sheet thì chỉnh sửa code ở đoạn nào ạ?

File đâu

vc_đi chơi · 2/11/19

HieuCD đã viết:
File đâu

Dạ đây ạ! anh xem giúp em.
Nếu có thể anh giúp em theo hướng khi thêm sheet vào file mà vẫn giãn dòng được vùng ô gộp cho sheet mới thêm.
Em cảm ơn anh!

HieuCD · 2/11/19

vc_đi chơi đã viết:
Dạ đây ạ! anh xem giúp em.
Nếu có thể anh giúp em theo hướng khi thêm sheet vào file mà vẫn giãn dòng được vùng ô gộp cho sheet mới thêm.
Em cảm ơn anh!

Cột cuối của tất cả các sheet lớn nhất là cột nào? ví dụ "X" hay "AAA"

vc_đi chơi · 2/11/19

HieuCD đã viết:
Cột cuối của tất cả các sheet lớn nhất là cột nào? ví dụ "X" hay "AAA"

Dạ cột cuối của sheet mà có nhiều cột nhất đúng không anh?
Anh lấy giúp em đến cột BZ anh ạ!
Cảm ơn anh!

HieuCD · 2/11/19

vc_đi chơi đã viết:
Dạ cột cuối của sheet mà có nhiều cột nhất đúng không anh?
Anh lấy giúp em đến cột BZ anh ạ!
Cảm ơn anh!

Tại sao có những dòng chồng lấn lên nhau? Code không xét trường hợp nầy

Mã:

Sub Autofit_dong()
  Dim Dic As Object, wb As Workbook, sh As Worksheet
  Dim sRng As Range, Rng As Range, iCel As Range, tmp As Range
  Dim rMax&, cMax&
  Dim i&, j&, tmpHight As Double, iStr$
  Const Diff As Single = 0.75
 
  With Application.FileDialog(msoFileDialogFilePicker)
    .Filters.Add "All Excel", "*.xls*"
    .AllowMultiSelect = False
    .Show
    If .SelectedItems.Count Then
      Application.DisplayAlerts = False
      Application.ScreenUpdating = False
      Set wb = Workbooks.Open(.SelectedItems(1), , False)
      Application.DisplayAlerts = True
      Set Dic = CreateObject("scripting.dictionary")
      For n = 1 To wb.Sheets.Count
        Set sh = wb.Sheets(n)
        Set sRng = sh.UsedRange
        For Each Rng In sRng
          i = Rng.Row: j = Rng.Row
          If rMax < i Then rMax = j:   If cMax < j Then cMax = j
        Next Rng
        Set tmp = sh.Cells(rMax + 2, cMax + 2)
        tmp.WrapText = True
        Set sRng = sh.UsedRange.SpecialCells(xlCellTypeConstants)
        For Each iCel In sRng
          If Len(iCel.Value) Then
            If iCel.MergeCells = True Then
              Set Rng = iCel.MergeArea
              If Dic.exists(Rng.Address) = False Then
                Dic.Add Rng.Address, ""
                Rng.WrapText = True
                sRngWidth = -Diff
                For j = 1 To Rng.Columns.Count
                  sRngWidth = sRngWidth + Rng(1, j).ColumnWidth + Diff
                Next j
                iCel.Copy
                tmp.PasteSpecial Paste:=xlPasteValues
                tmp.PasteSpecial Paste:=xlPasteFormats
                tmp.ColumnWidth = sRngWidth
                tmp.EntireRow.AutoFit
                Rng.RowHeight = tmp.RowHeight / Rng.Rows.Count
              End If
            End If
          End If
        Next iCel
        tmp.ClearContents
        sh.Rows(rMax + 2).EntireRow.AutoFit
        Dic.RemoveAll
      Next n
      Application.ScreenUpdating = True
    End If
  End With
End Sub

Mở file bấm mặt cười chạy code
Chọn File cần fix dòng, nhấn Ok.
Lưu ý nếu file cần fix đang mở, cần lưu lại trước khi chạy code

be_09 · 2/11/19

vc_đi chơi đã viết:
Dạ đây ạ! anh xem giúp em.
Nếu có thể anh giúp em theo hướng khi thêm sheet vào file mà vẫn giãn dòng được vùng ô gộp cho sheet mới thêm.
Em cảm ơn anh!

Góp ý cho bạn:
1/ Muốn làm bất cứ việc gì thì cũng nên giới hạn vùng và vị trí của nó chứ không thể để Merge And Center lung tung và không có trật tự gì cả, vì làm như bạn thì code sẽ dò tìm hết tất cả những chỗ có nhập liệu sau đó mới chọn những chỗ có Merge And Center dẫn đến tiêu phí vào những chỗ không cần thiết nên code sẽ chạy chậm, cụ thể code ở bài kia tôi chỉ cho code thực hiện ở những chỗ có Merge And Center. Nay bạn cần code sử dụng cho nhiều sheet phải viết code khác đi.
2/ Tốt nhất là bạn nên thiết kế sẳn các mẫu cần thiết vào các sheet cần thực hiện và tô màu vào những chỗ cần co giản dòng.

vc_đi chơi · 3/11/19

be09 đã viết:
Góp ý cho bạn:
1/ Muốn làm bất cứ việc gì thì cũng nên giới hạn vùng và vị trí của nó chứ không thể để Merge And Center lung tung và không có trật tự gì cả, vì làm như bạn thì code sẽ dò tìm hết tất cả những chỗ có nhập liệu sau đó mới chọn những chỗ có Merge And Center dẫn đến tiêu phí vào những chỗ không cần thiết nên code sẽ chạy chậm, cụ thể code ở bài kia tôi chỉ cho code thực hiện ở những chỗ có Merge And Center. Nay bạn cần code sử dụng cho nhiều sheet phải viết code khác đi.
2/ Tốt nhất là bạn nên thiết kế sẳn các mẫu cần thiết vào các sheet cần thực hiện và tô màu vào những chỗ cần co giản dòng.

Vâng, vì em không biết về code nên cũng khó!
Cảm ơn anh!

Bài đã được tự động gộp: 3/11/19

HieuCD đã viết:

Tại sao có những dòng chồng lấn lên nhau? Code không xét trường hợp nầy

Mã:

Sub Autofit_dong()
  Dim Dic As Object, wb As Workbook, sh As Worksheet
  Dim sRng As Range, Rng As Range, iCel As Range, tmp As Range
  Dim rMax&, cMax&
  Dim i&, j&, tmpHight As Double, iStr$
  Const Diff As Single = 0.75

  With Application.FileDialog(msoFileDialogFilePicker)
    .Filters.Add "All Excel", "*.xls*"
    .AllowMultiSelect = False
    .Show
    If .SelectedItems.Count Then
      Application.DisplayAlerts = False
      Application.ScreenUpdating = False
      Set wb = Workbooks.Open(.SelectedItems(1), , False)
      Application.DisplayAlerts = True
      Set Dic = CreateObject("scripting.dictionary")
      For n = 1 To wb.Sheets.Count
        Set sh = wb.Sheets(n)
        Set sRng = sh.UsedRange
        For Each Rng In sRng
          i = Rng.Row: j = Rng.Row
          If rMax < i Then rMax = j:   If cMax < j Then cMax = j
        Next Rng
        Set tmp = sh.Cells(rMax + 2, cMax + 2)
        tmp.WrapText = True
        Set sRng = sh.UsedRange.SpecialCells(xlCellTypeConstants)
        For Each iCel In sRng
          If Len(iCel.Value) Then
            If iCel.MergeCells = True Then
              Set Rng = iCel.MergeArea
              If Dic.exists(Rng.Address) = False Then
                Dic.Add Rng.Address, ""
                Rng.WrapText = True
                sRngWidth = -Diff
                For j = 1 To Rng.Columns.Count
                  sRngWidth = sRngWidth + Rng(1, j).ColumnWidth + Diff
                Next j
                iCel.Copy
                tmp.PasteSpecial Paste:=xlPasteValues
                tmp.PasteSpecial Paste:=xlPasteFormats
                tmp.ColumnWidth = sRngWidth
                tmp.EntireRow.AutoFit
                Rng.RowHeight = tmp.RowHeight / Rng.Rows.Count
              End If
            End If
          End If
        Next iCel
        tmp.ClearContents
        sh.Rows(rMax + 2).EntireRow.AutoFit
        Dic.RemoveAll
      Next n
      Application.ScreenUpdating = True
    End If
  End With
End Sub

Mở file bấm mặt cười chạy code
Chọn File cần fix dòng, nhấn Ok.
Lưu ý nếu file cần fix đang mở, cần lưu lại trước khi chạy code

Cảm ơn anh, có cách nào mà đưa code vào luôn file excel và chạy trực tiếp trên file đó luôn được không anh?

quanglenb · 11/12/19

be09 đã viết:
Thử File.

Em có xem code anh viết để giãn dòng tự động.

Mã:

Option Explicit

Sub CoGianDong_Hai()
Dim Dchinh As Single
Dim DRong As Range
Dim RDong As Range
Dim RCot As Double
Dim DchinhHang As Double
Dim Mang As Variant
Dim i As Integer

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Sheet1

'Thay doi Cell trong Mang cho phù hop
Mang = Array("D11", "D13", "D16", "G17", "D18", "D20", "D21")
    For i = 0 To UBound(Mang)
        On Error Resume Next
        Set RDong = Range(Range(Mang(i)).MergeArea.Address)
        RDong.MergeCells = False
        RCot = RDong.Cells(1).ColumnWidth
        Dchinh = 0
            For Each DRong In RDong
                DRong.WrapText = True
                Dchinh = DRong.ColumnWidth + Dchinh
            Next
        Dchinh = Dchinh + RDong.Cells.Count * 0.1
        RDong.Cells(1).ColumnWidth = Dchinh
        RDong.EntireRow.AutoFit
        DchinhHang = RDong.RowHeight
        RDong.Cells(1).ColumnWidth = RCot
        RDong.MergeCells = True
        RDong.RowHeight = DchinhHang
    Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End With

End Sub

Xin được hỏi anh:
đoạn code:

Mã:

Mang = Array("D11", "D13", "D16", "G17", "D18", "D20", "D21")

Sẽ được duyệt qua tất cả các Sheet có vùng được gộp tương ứng như trên đúng không ạ?
Nếu sửa đoạn code trên thành

Mã:

Mang = Array([D11:D21])

Có được không anh? và em không muốn duyệt qua tất cả các sheet chứa nhiều vùng được gộp mà chỉ muốn code có tác dụng trên một sheet nào đó để cho code chạy nhanh thì phải sửa phần nào trong code anh đã giúp ở trên ạ?

Nhờ giúp sửa code co giãn dòng tự động

le_vis

Thành viên tích cực

File đính kèm

VetMini

Ăn cùng góc phố

be_09

Biên Hòa, Đồng Nai

File đính kèm

HieuCD

Chuyên gia GPE

File đính kèm

le_vis

Thành viên tích cực

vc_đi chơi

Thành viên hoạt động

vc_đi chơi

Thành viên hoạt động

HieuCD

Chuyên gia GPE

vc_đi chơi

Thành viên hoạt động

File đính kèm

HieuCD

Chuyên gia GPE

vc_đi chơi

Thành viên hoạt động

HieuCD

Chuyên gia GPE

File đính kèm

be_09

Biên Hòa, Đồng Nai

vc_đi chơi

Thành viên hoạt động

quanglenb

Thành viên hoạt động

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng