Chạy SubTô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 !
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
Thử File.[/QUOTE
Cảm ơn thầy - Rất gọn và chuẩn - Tốc độ
Em có tham khảo đoạn code Bác viết, rất hay và tốc độ.Thử File.
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
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 ạ?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 đâuAnh ơ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 ạ?
Dạ đây ạ! anh xem giúp em.File đâu
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ạ đâ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!
Dạ cột cuối của sheet mà có nhiều cột nhất đúng không 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"
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ầyDạ 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!
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
Góp ý cho bạn: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!
Vâng, vì em không biết về code nên cũng khó!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.
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?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ở file bấm mặt cười chạy codeMã: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
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
Em có xem code anh viết để giãn dòng tự động.Thử File.
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
Mang = Array("D11", "D13", "D16", "G17", "D18", "D20", "D21")
Mang = Array([D11:D21])