Tặng các bạn code AutoFit Row với Merge Cells (nhiều hàng, nhiều cột).

Hoàng Trọng Nghĩa · 4/7/15

Các bài mà trước đây mà nhiều người viết trong đó có tôi đều cho ra kết quả, nhưng thật sự nó vẫn chưa fit hoàn toàn, có khi dư chiều cao hàng (Height) rất nhiều.

Sau khi ngồi tính toán lại tôi viết thủ tục dưới đây, nhằm fit lại những cái chênh lệch đó, đồng thời chúng ta có thể Fit cho các vùng merge cells nhiều hàng, nhiều cột.

Thủ tục:

Mã:

Sub MergeCellFit(ByVal MergeCells As Range)
    Dim Diff As Single
    Dim FirstCell As Range, MergeCellArea As Range
    Dim Col As Long, ColCount As Long, RowCount As Long
    Dim FirstCellWidth As Double, FirstCellHeight As Double, MergeCellWidth As Double
    If MergeCells.Count = 1 Then
        Set MergeCellArea = MergeCells.MergeArea
    Else
        Set MergeCellArea = MergeCells
    End If
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    With MergeCellArea
        ColCount = .Columns.Count
        RowCount = .Rows.Count
        .WrapText = True
        If RowCount = 1 And ColCount = 1 Then
            .EntireRow.AutoFit
            GoTo ExitSub
        End If
        Set FirstCell = .Cells(1, 1)
        FirstCellWidth = FirstCell.ColumnWidth
        Diff = 0.75
        For Col = 1 To ColCount
            MergeCellWidth = MergeCellWidth + .Cells(1, Col).ColumnWidth + Diff
        Next
        .MergeCells = False
        FirstCell.ColumnWidth = MergeCellWidth - Diff
        .EntireRow.AutoFit
        FirstCellHeight = FirstCell.RowHeight
        .MergeCells = True
        FirstCell.ColumnWidth = FirstCellWidth
        FirstCellHeight = FirstCellHeight / RowCount
        .RowHeight = FirstCellHeight
    End With
ExitSub:
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Cách thực hiện:

Ví dụ khối ô MergeCell cần AutoFit là: C6:L9

Ta chỉ cần lấy tham chiếu ô đầu tiên là C6 (dùng cả C6:L9 cũng OK)

Và thủ tục chạy chỉ như sau:

Mã:

MergeCellFit Range("[B][COLOR=#FF0000]C6[/COLOR][/B]")

Hoặc:

Mã:

MergeCellFit Range("[B]C6:L9[/B]")

Hoặc thậm chí chỉ là một cell nào đó trong khối mergecell:

Mã:

MergeCellFit Range("[B][COLOR=#FF0000]E6[/COLOR][/B]")

langtuchungtinh360 · 9/7/15

hoàng trọng nghĩa đã viết:
các bài mà trước đây mà nhiều người viết trong đó có tôi đều cho ra kết quả, nhưng thật sự nó vẫn chưa fit hoàn toàn, có khi dư chiều cao hàng (height) rất nhiều.

Sau khi ngồi tính toán lại tôi viết thủ tục dưới đây, nhằm fit lại những cái chênh lệch đó, đồng thời chúng ta có thể fit cho các vùng merge cells nhiều hàng, nhiều cột.

Thủ tục:

Mã:

sub mergecellfit(byval mergecells as range) dim diff as single dim firstcell as range, mergecellarea as range dim col as long, colcount as long, rowcount as long dim firstcellwidth as double, firstcellheight as double, mergecellwidth as double if mergecells.count = 1 then set mergecellarea = mergecells.mergearea else set mergecellarea = mergecells end if application.screenupdating = false application.enableevents = false application.calculation = xlcalculationmanual with mergecellarea colcount = .columns.count rowcount = .rows.count .wraptext = true if rowcount = 1 and colcount = 1 then .entirerow.autofit goto exitsub end if set firstcell = .cells(1, 1) firstcellwidth = firstcell.columnwidth diff = 0.75 for col = 1 to colcount mergecellwidth = mergecellwidth + .cells(1, col).columnwidth + diff next .mergecells = false firstcell.columnwidth = mergecellwidth - diff .entirerow.autofit firstcellheight = firstcell.rowheight .mergecells = true firstcell.columnwidth = firstcellwidth firstcellheight = firstcellheight / rowcount .rowheight = firstcellheight end with exitsub: Application.calculation = xlcalculationautomatic application.enableevents = true application.screenupdating = true end sub

cách thực hiện:

Ví dụ khối ô mergecell cần autofit là: c6:l9

ta chỉ cần lấy tham chiếu ô đầu tiên là c6 (dùng cả c6:l9 cũng ok)

và thủ tục chạy chỉ như sau:

Mã:

mergecellfit range("[b][color=#ff0000]c6[/color][/b]")

hoặc:

Mã:

mergecellfit range("[b]c6:l9[/b]")

hoặc thậm chí chỉ là một cell nào đó trong khối mergecell:

Mã:

mergecellfit range("[b][color=#ff0000]e6[/color][/b]")

rất ngon bác à. Nhưng chỉ dùng được khi khai báo ô cần fix trước. Bác có thể làm thêm cho nó tự động tìm những merge rồi để fix không bác.

huuthang_bd · 9/7/15

Hoàng Trọng Nghĩa đã viết:
Các bài mà trước đây mà nhiều người viết trong đó có tôi đều cho ra kết quả, nhưng thật sự nó vẫn chưa fit hoàn toàn, có khi dư chiều cao hàng (Height) rất nhiều.

Sau khi ngồi tính toán lại tôi viết thủ tục dưới đây, nhằm fit lại những cái chênh lệch đó, đồng thời chúng ta có thể Fit cho các vùng merge cells nhiều hàng, nhiều cột.

Thủ tục:

Mã:

Sub MergeCellFit(ByVal MergeCells As Range) Dim Diff As Single Dim FirstCell As Range, MergeCellArea As Range Dim Col As Long, ColCount As Long, RowCount As Long Dim FirstCellWidth As Double, FirstCellHeight As Double, MergeCellWidth As Double If MergeCells.Count = 1 Then Set MergeCellArea = MergeCells.MergeArea Else Set MergeCellArea = MergeCells End If Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual With MergeCellArea ColCount = .Columns.Count RowCount = .Rows.Count .WrapText = True If RowCount = 1 And ColCount = 1 Then .EntireRow.AutoFit GoTo ExitSub End If Set FirstCell = .Cells(1, 1) FirstCellWidth = FirstCell.ColumnWidth Diff = 0.75 For Col = 1 To ColCount MergeCellWidth = MergeCellWidth + .Cells(1, Col).ColumnWidth + Diff Next .MergeCells = False FirstCell.ColumnWidth = MergeCellWidth - Diff .EntireRow.AutoFit FirstCellHeight = FirstCell.RowHeight .MergeCells = True FirstCell.ColumnWidth = FirstCellWidth FirstCellHeight = FirstCellHeight / RowCount .RowHeight = FirstCellHeight End With ExitSub: Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True Application.ScreenUpdating = True End Sub

Cách thực hiện:

Ví dụ khối ô MergeCell cần AutoFit là: C6:L9

Ta chỉ cần lấy tham chiếu ô đầu tiên là C6 (dùng cả C6:L9 cũng OK)

Và thủ tục chạy chỉ như sau:

Mã:

MergeCellFit Range("[B][COLOR=#FF0000]C6[/COLOR][/B]")

Hoặc:

Mã:

MergeCellFit Range("[B]C6:L9[/B]")

Hoặc thậm chí chỉ là một cell nào đó trong khối mergecell:

Mã:

MergeCellFit Range("[B][COLOR=#FF0000]E6[/COLOR][/B]")

Code này cũng chưa chính xác. Có trường hợp thừa, có trường hợp thiếu.

Hoàng Trọng Nghĩa · 21/8/15

langtuchungtinh360 đã viết:
rất ngon bác à. Nhưng chỉ dùng được khi khai báo ô cần fix trước. Bác có thể làm thêm cho nó tự động tìm những merge rồi để fix không bác.

Giả sử trong khối ô từ C1:C14 có chứa Merge thì dùng thủ tục này:

Mã:

Sub FitAll()
    Dim Cls As Range
    For Each Cls In Range("C1:C14")
        MergeCellFit Cls
    Next
End Sub

Tức nó chỉ nhận các ô đầu chứa Merge mà thực hiện theo hàng đó thôi.

chantinh2th · 21/8/15

Thay vì trả lời em ở Box kia, anh đã update theart này như một cách trả lời và nhắc nhở em sử dụng chức năng Search diễn đàn **~**

. Dù sao đạt được mục đích mới là quan trọng. Rất cảm ơn anh Nghĩa đập chai!!!! -=.,,

chantinh2th · 21/8/15

Hoàng Trọng Nghĩa đã viết:
Giả sử trong khối ô từ C1:C14 có chứa Merge thì dùng thủ tục này:

Mã:

Sub FitAll() Dim Cls As Range For Each Cls In Range("C1:C14") MergeCellFit Cls Next End Sub

Tức nó chỉ nhận các ô đầu chứa Merge mà thực hiện theo hàng đó thôi.

Anh ơi! Đoạn Code này nếu chọn vùng dữ liệu dài quá, vd từ C1:C500, nó nhấp nháy liên tục, tốc độ xử lý của nó hơi chậm. Có cách nào tăng tốc nó lên không anh

chuot0106 · 21/8/15

chantinh2th đã viết:
Anh ơi! Đoạn Code này nếu chọn vùng dữ liệu dài quá, vd từ C1:C500, nó nhấp nháy liên tục, tốc độ xử lý của nó hơi chậm. Có cách nào tăng tốc nó lên không anh

Duyệt qua từng ô thì phải chịu vậy thôi!

lovelycat182 · 21/8/15

Dạ xin chào mọi người,mọi người ai có phần mếm thêm dòng xoá cột ,thêm cột cho em xin được không ah.Em cam on nhieu .Mail em la:trinhtuyet82@yahoo.com.vn $-\\/.$ $-\\/.$ $-\\/.$

Hoàng Trọng Nghĩa · 21/8/15

chantinh2th đã viết:
Anh ơi! Đoạn Code này nếu chọn vùng dữ liệu dài quá, vd từ C1:C500, nó nhấp nháy liên tục, tốc độ xử lý của nó hơi chậm. Có cách nào tăng tốc nó lên không anh

Tôi chỉ hoán đổi một chút từ code này qua code kia thôi, hy vọng nó chạy mượt hơn tí xíu:

Mã:

Sub FitAll()
[COLOR=#008080]    Application.ScreenUpdating = False[/COLOR]
[COLOR=#008080]    Application.EnableEvents = False[/COLOR]
[COLOR=#008080]    Application.Calculation = xlCalculationManual[/COLOR]
    Dim Cls As Range
    For Each Cls In Range("C1:C14")
        MergeCellFit Cls
    Next
[COLOR=#008080]    Application.Calculation = xlCalculationAutomatic[/COLOR]
[COLOR=#008080]    Application.EnableEvents = True[/COLOR]
[COLOR=#008080]    Application.ScreenUpdating = True[/COLOR]
End Sub


Sub MergeCellFit(ByVal MergeCells As Range)
    Dim Diff As Single
    Dim FirstCell As Range, MergeCellArea As Range
    Dim Col As Long, ColCount As Long, RowCount As Long
    Dim FirstCellWidth As Double, FirstCellHeight As Double, MergeCellWidth As Double
    If MergeCells.Count = 1 Then
        Set MergeCellArea = MergeCells.MergeArea
    Else
        Set MergeCellArea = MergeCells
    End If
    With MergeCellArea
        ColCount = .Columns.Count
        RowCount = .Rows.Count
        .WrapText = True
        If RowCount = 1 And ColCount = 1 Then
            .EntireRow.AutoFit
            GoTo ExitSub
        End If
        Set FirstCell = .Cells(1, 1)
        FirstCellWidth = FirstCell.ColumnWidth
        Diff = 0.75
        For Col = 1 To ColCount
            MergeCellWidth = MergeCellWidth + .Cells(1, Col).ColumnWidth + Diff
        Next
        .MergeCells = False
        FirstCell.ColumnWidth = MergeCellWidth - Diff
        .EntireRow.AutoFit
        FirstCellHeight = FirstCell.RowHeight
        .MergeCells = True
        FirstCell.ColumnWidth = FirstCellWidth
        FirstCellHeight = FirstCellHeight / RowCount
        .RowHeight = FirstCellHeight
    End With
ExitSub:
End Sub

chantinh2th · 21/8/15

Sub FitAll()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim Cls As Range, i As Integer
For i = 2 To 4
For Each Cls In Sheets(i).Range("C1026")
MergeCellFit Cls
Next
Next
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "Ok, Tuyet voi"
End Sub

Trong bài của em, em cho nó chạy qua 3 sheet * 32 ô cell mỗi sheet, nó duyệt hết số cell này mất 11 giây. Nếu làm cho toàn bộ số sheet trong Form 30 sheet của em có khi phải tậu máy mới mới giải quyết nổi. Cảm ơn anh đã chia sẽ!!!

Hoàng Trọng Nghĩa · 21/8/15

chantinh2th đã viết:
Trong bài của em, em cho nó chạy qua 3 sheet * 32 ô cell mỗi sheet, nó duyệt hết số cell này mất 11 giây. Nếu làm cho toàn bộ số sheet trong Form 30 sheet của em có khi phải tậu máy mới mới giải quyết nổi. Cảm ơn anh đã chia sẽ!!!

Bạn chỉ nên làm 1 cột thôi, cột đó có chứa Merge, chẳng hạn C10:C26, chứ đừng làm C10

26.
Ví dụ bạn Merge 1 khối ô gồm C10

12, C13

16, v.v... thì bạn vẫn cứ chỉ quét C10:C26, nó luôn nhận biết và duyệt qua từng ô, cho dù bạn vừa merge cột và hàng nó vẫn quét qua. Nếu cột D không liên quan gì đến Merge thì ta lại tiếp tục quét từ D10

26, đại loại là như vậy.

khongnhienttt · 12/10/15

rất cám ơn anh nghĩa, những tiện ích của anh lúc nào cũng ngon

khongnhienttt · 13/10/15

code này nó vẫn còn 1 số lỗi anh #Nghĩa ơi, chưa cần xuống hàng thì nó đã xuống, mong anh kiểm tra lại, vì khi dùng excel để thay thế mailing trong word thì rất cần code này của anh

Hoàng Trọng Nghĩa · 13/10/15

khongnhienttt đã viết:
code này nó vẫn còn 1 số lỗi anh #Nghĩa ơi, chưa cần xuống hàng thì nó đã xuống, mong anh kiểm tra lại, vì khi dùng excel để thay thế mailing trong word thì rất cần code này của anh
View attachment 148710

Cụ thể là cái gì trong file bạn? Bạn gửi file mẫu và đưa cái kết quả cần thực hiện sẽ như thế nào.

langtuchungtinh360 · 13/10/15

Hoàng Trọng Nghĩa đã viết:
Cụ thể là cái gì trong file bạn? Bạn gửi file mẫu và đưa cái kết quả cần thực hiện sẽ như thế nào.

ở chỗ "Chỗ ở hiện nay: số 630B/1........." đó thầy.
chắc là do đặt tab hay thừa khoảng trắng.

Hoàng Trọng Nghĩa · 13/10/15

langtuchungtinh360 đã viết:
ở chỗ "Chỗ ở hiện nay: số 630B/1........." đó thầy.
chắc là do đặt tab hay thừa khoảng trắng.

Trời ơi, không có file tôi test làm sao chẩn đoán bịnh đây? ;;;;;;;;;;;

doveandrose · 13/10/15

Hoàng Trọng Nghĩa đã viết:
Trời ơi, không có file tôi test làm sao chẩn đoán bịnh đây?

thì cái dòng khoanh tròn trong tấm hình đó . anh cứ dựa vào tấm hình mà đoán

langtuchungtinh360 · 20/10/15

Hoàng Trọng Nghĩa đã viết:
Trời ơi, không có file tôi test làm sao chẩn đoán bịnh đây?

thầy xem tạm file này nha. chả hiểu sao, tại ô A1 có Wrap text

Hoàng Trọng Nghĩa · 20/10/15

langtuchungtinh360 đã viết:
thầy xem tạm file này nha. chả hiểu sao, tại ô A1 có Wrap text

Thật sự mà nói đó chả có lỗi gì, bởi khi hiển thị, tùy thuộc vào font mà ta có thể thấy nó fit, nhưng print preview nó lại thiếu chữ hoặc nó hiển thị ##### trong cái ô đó., cho nên trước khi in hay làm gì cũng mở print preview xem trước nó có bị gì không để mà điều chỉnh cột lại cho hợp lý.

Bạn thử làm vậy với file bạn vừa gửi xem! Sẽ thấy chữ g nó rơi xuống dòng dưới đó. Như thế chỉ cần giản độ rộng của cột ra một tí là được.

Chính vì tôi biết điều này, nên các Label trong UserForm tôi đều cho nó rộng ra một chút chứ không Fit nó vừa khít chiều rộng. Khi form show đôi khi nó lại mất chữ. Điều này chứng minh rằng nó xảy ra không chỉ trên sheet.

langtuchungtinh360 · 21/10/15

Hoàng Trọng Nghĩa đã viết:
Thật sự mà nói đó chả có lỗi gì, bởi khi hiển thị, tùy thuộc vào font mà ta có thể thấy nó fit, nhưng print preview nó lại thiếu chữ hoặc nó hiển thị ##### trong cái ô đó., cho nên trước khi in hay làm gì cũng mở print preview xem trước nó có bị gì không để mà điều chỉnh cột lại cho hợp lý.

Bạn thử làm vậy với file bạn vừa gửi xem! Sẽ thấy chữ g nó rơi xuống dòng dưới đó. Như thế chỉ cần giản độ rộng của cột ra một tí là được.

Chính vì tôi biết điều này, nên các Label trong UserForm tôi đều cho nó rộng ra một chút chứ không Fit nó vừa khít chiều rộng. Khi form show đôi khi nó lại mất chữ. Điều này chứng minh rằng nó xảy ra không chỉ trên sheet.

em cảm ơn thầy. thầy có thể viết giùm em 1 code mà nội dung code là tìm các ô có số nào bị ##### thì tự động giãn cột ra luôn được không thầy. chứ ngồi xem từng trang trước khi in mà tìm ô bị lỗi hiển thị ##### để fix lại thì lâu chết được thầy ạ

Tặng các bạn code AutoFit Row với Merge Cells (nhiều hàng, nhiều cột).

Chuyên gia GPE

File đính kèm

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

Chuyên gia GPE

File đính kèm

Chuyên gia GPE

Thành viên mới

Thành viên mới

Thành viên gắn bó

Thành viên mới

Chuyên gia GPE

Thành viên mới

Chuyên gia GPE

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

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

Chuyên gia GPE

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

Chuyên gia GPE

hello

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

File đính kèm

Chuyên gia GPE

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