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

Liên hệ QC
L

le_vis

Thành viên tích cực
Tham gia
23/7/09
Bài viết
1,243
Được thích
754
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 !
 

File đính kèm

  • DÃN DÒNG TỰ ĐỘNG.xlsm
    18.8 KB · Đọc: 14
Sắp xếp theo thời gian sắp xếp theo bầu chọn
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.
 
Upvote 0
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 !
Nhấp chuột vào đây để mở rộng...
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
 

File đính kèm

  • DÃN DÒNG TỰ ĐỘNG.xlsm
    22.3 KB · Đọc: 27
Upvote 0
be09 đã viết:
Thử File.
Nhấp chuột vào đây để mở rộng...
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!
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...
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 ạ?
 
Upvote 0
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!
Nhấp chuột vào đây để mở rộng...
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
 

File đính kèm

  • FixDong.xlsm
    17.9 KB · Đọc: 14
Upvote 0
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!
Nhấp chuột vào đây để mở rộng...
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.
 
Lần chỉnh sửa cuối:
Upvote 0
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.
Nhấp chuột vào đây để mở rộ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:

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
Nhấp chuột vào đây để mở rộng...
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?
 
Upvote 0
be09 đã viết:
Thử File.
Nhấp chuột vào đây để mở rộng...
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 ạ?
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

B
Optimal Сasual Dating - Real Women
Trả lời
0
Đọc
1
beijin
B
phanmoi688
[Xin nhờ giúp đỡ] Cách đối chiếu dữ liệu giữa hai biểu
    • Thích
Trả lời
5
Đọc
78
HUONGHCKT
H
O
Nhờ sửa code tự động trừ đi một giá trị trong vùng được chọn
Trả lời
2
Đọc
28
Phuocam
Phuocam
A
  • Question
cách dùng lockxls bảo vệ file
Trả lời
14
Đọc
3K
YêuCN
Y
LuuAnh980
Ổ đĩa mạng có màu đỏ.
Trả lời
9
Đọc
123
LuuAnh980
LuuAnh980
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

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

Back
Top Bottom