Tự động giãn độ cao vừa đủ cho ký tự một lúc nhiều ô đã sát nhập (1 người xem)

[Nguyễn Xuân Sơn]

Kính gửi các bạn trong 4R.
Giả sử tôi có một fie như đính kèm dưới đây. Có một ( một vài ) đoạn văn mà các dòng đã được sát nhập các ô, độ cao dòng không đủ để hiển thị hết các ký tự đọan văn trong từng dòng. Nếu kéo thủ công từng dòng rất mất thời gian mà không cẩn thận lại bị sót nữa. Vậy có đoạn mã nào giải quyết việc tự động giãn ( vừa đủ ) tất cả các dòng không? Xin các bạn chỉ giáo.
Cảm ơn các bạn nhiều!

 

[PhanTuHuong]

Bạn dùng chức năng record để biết chế độ tự động AutoHeigh của Row, sau đó lấy địa chỉ dòng vừa sửa và lập trình sự kiện Change là được thôi.

 

[phamduylong]

Kính gửi các bạn trong 4R.
Giả sử tôi có một fie như đính kèm dưới đây. Có một ( một vài ) đoạn văn mà các dòng đã được sát nhập các ô, độ cao dòng không đủ để hiển thị hết các ký tự đọan văn trong từng dòng. Nếu kéo thủ công từng dòng rất mất thời gian mà không cẩn thận lại bị sót nữa.

Tôi cũng đau đầu vì việc này. Phải kiểm tra, chỉnh độ cao trước khi in, mất thì giờ nhưng vẫn thường bỏ sót vài dùng dữ liệu nào đó khi in.
Theo tôi biết, Excel chỉ tự động chỉnh độ cao dòng ô đơn khi chọn Wrap text hoặc xuống dòng trong ô (Alt+Enter). Với các ô Merge Cells không có tác dụng (chọn Format > Row > Autofit thì Excel chỉnh lại độ cao đúng 1 dòng, che mất các dòng dưới)
Các bạn có cách nào giải quyết việc chỉ giúp.

Vậy có đoạn mã nào giải quyết việc tự động giãn ( vừa đủ ) tất cả các dòng không? Xin các bạn chỉ giáo.

Với mỗi font chữ, cở font khác nhau thì số ký tự hiển thị được theo bề ngang của cột khác nhau nên rất khó viết.

 

[rollover79]

Yêu cầu này nếu chỉ merge các ô trên 1 dòng thì có thể dùng tạm doạn code này

Sub AutoFitHeight()
    Dim rng As Range
    Set rng = ActiveSheet.UsedRange
    rng.Copy
    Dim rngTemp As Range
    Set rngTemp = Range("Sheet2!" & rng.Address)
    rngTemp.PasteSpecial xlPasteAll
    rngTemp.MergeCells = False
    rngTemp.WrapText = True
    rngTemp.Rows.AutoFit
    Dim H As Double
    For i = rng.Rows.Count + rng.Row - 1 To rng.Row Step -1
        Rows(i).RowHeight = Sheet2.Rows(i).RowHeight
    Next
End Sub

Bác nào thấy cần thiết thì code thêm tí nữa nhé. Nếu có merge các ô trên nhiều dòng với nhau thì độ cao của các ô sẽ bị thừa(chính là độ cao của các dòng phía dưới), cố tính toán thêm chút nữa chắc cũng có thể được nhưng mới nghĩ đến đã thay dài dòng ngại nghĩ quá .

 

[Nguyễn Xuân Sơn]

Yêu cầu này nếu chỉ merge các ô trên 1 dòng thì có thể dùng tạm doạn code này

Đúng vậy ...... bạn xem file đính kèm để thấy rõ hơn ý đồ mình muốn nhờ. Còn nếu chỉ sát nhập các ô một thành một dòng thì bác anhtuan 1066 đã chỉ giáo rồi.

 

[rollover79]

Đúng vậy ...... bạn xem file đính kèm để thấy rõ hơn ý đồ mình muốn nhờ. Còn nếu chỉ sát nhập các ô một thành một dòng thì bác anhtuan 1066 đã chỉ giáo rồi.

Vậy bạn thử đoạn code này xem có đáp ứng được yêu cầu của bạn ko nhé, code hơi dài dòng chút.

Sub AutoFitAllRowWithMergeCells()
    Application.ScreenUpdating = False
    Dim currentSheet As Worksheet
    Dim newSheet As Worksheet
    Dim currentRange As Range
    Dim newRange As Range
    
    Set currentSheet = ActiveSheet
    Set newSheet = Worksheets.Add
    currentSheet.Select
    Set currentRange = currentSheet.UsedRange
    Set newRange = newSheet.Range(currentRange.Address)
    
    Dim arrayRowsToMerge() As Double
    ReDim arrayRowsToMerge(currentRange.Row To currentRange.Rows.Count + currentRange.Row - 1)
    Dim arrayColumnToMerge() As Long
    ReDim arrayColumnToMerge(currentRange.Column To currentRange.Columns.Count + currentRange.Column - 1)
    
    Dim cellTemp As Range
    Dim iRow As Long
    Dim iCol As Long
    For Each cellTemp In currentRange.Cells
        iRow = cellTemp.Row
        iCol = cellTemp.Column
        If cellTemp.MergeArea.Rows.Count > 0 And cellTemp.MergeArea.Row = cellTemp.Row Then
            If cellTemp.MergeArea.Rows.Count > arrayRowsToMerge(iRow) Then
                arrayRowsToMerge(iRow) = cellTemp.MergeArea.Rows.Count
            End If
            If cellTemp.MergeArea.Columns.Count > arrayColumnToMerge(iCol) Then
                arrayColumnToMerge(iCol) = cellTemp.MergeArea.Columns.Count
            End If
        End If
    Next
    
    currentRange.Copy
    newRange.PasteSpecial xlPasteAll
    newRange.MergeCells = False
    newRange.WrapText = True
    
    Dim j As Long
    Dim iColWidth As Double
    For iCol = newRange.Column + newRange.Columns.Count - 1 To newRange.Column Step -1
        iColWidth = Columns(iCol).ColumnWidth
        For j = 2 To arrayColumnToMerge(iCol)
            iColWidth = iColWidth + Columns(iCol + j - 1).ColumnWidth
        Next
        newSheet.Columns(iCol).ColumnWidth = iColWidth
    Next
    
    newRange.Rows.AutoFit
    
    Dim iRowHeight As Double
    
    For iRow = currentRange.Row + currentRange.Rows.Count - 1 To currentRange.Row Step -1
        iRowHeight = newSheet.Rows(iRow).RowHeight
        For j = 2 To arrayRowsToMerge(iRow)
            If iRowHeight - Rows(iRow + j - 1).RowHeight > 0 Then iRowHeight = iRowHeight - Rows(iRow + j - 1).RowHeight
        Next
        Rows(iRow).RowHeight = iRowHeight
    Next
    Application.DisplayAlerts = False
    newSheet.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

[huuthang_bd]

Kính gửi các bạn trong 4R.
Giả sử tôi có một fie như đính kèm dưới đây. Có một ( một vài ) đoạn văn mà các dòng đã được sát nhập các ô, độ cao dòng không đủ để hiển thị hết các ký tự đọan văn trong từng dòng. Nếu kéo thủ công từng dòng rất mất thời gian mà không cẩn thận lại bị sót nữa. Vậy có đoạn mã nào giải quyết việc tự động giãn ( vừa đủ ) tất cả các dòng không? Xin các bạn chỉ giáo.
Cảm ơn các bạn nhiều!

Tôi có một đoạn code hơi củ chuối nhưng xài đc
Chọn vùng cần Merge rồi chạy macro nha (Phím tắt của macro là Ctrl + Q)

 

[rollover79]

Tôi có một đoạn code hơi củ chuối nhưng xài đc
Chọn vùng cần Merge rồi chạy macro nha (Phím tắt của macro là Ctrl + Q)

Cái này chọn trên nhiều dòng để merge là có vấn đề.

 

[huuthang_bd]

Cái này chọn trên nhiều dòng để merge là có vấn đề.

Đoạn code của bạn cũng chạy trên cơ sở Merge rồi. Nếu chưa Merge có chạy được ko?? .
Đàng nào cũng phải chọn từng vùng thôi.

 

[rollover79]

Đoạn code của bạn cũng chạy trên cơ sở Merge rồi. Nếu chưa Merge có chạy được ko?? .
Đàng nào cũng phải chọn từng vùng thôi.

Bạn không hiểu ý của tôi rồi, merge thì cách nào rồi cũng phải chọn từng vùng để merge, nhưng bạn thử test code của bạn khi bạn chọn các 3 ô liền nhau trên cùng 1 cột rồi thực hiện xem nó có ra đúng độ cao như mong muốn không?

 

[Nguyễn Xuân Sơn]

Rất cảm ơn các bạn đã nhiệt tình tham gia đề tài tôi gửỉ lên 4R. Tôi đã cải tiến đoạn code của bác AT 1066 và thêm vòng lặp để chạy. Nhưng tốc độ chạy không bằng đoạn mã của bạn rollover79. Quả thật bạn đã rất sáng tạo khi tạo sheet phụ để dơn giản hóa vấn đề và cải thiện tốc độ ( vì không phải dùng vòng lặp phức tạp.
Rất cảm ơn bạn rollover79 và sự nhiệt tình của các bạn.

 

[nhungdoahoaphudung]

nhưng có vẻ đoạn code chưa ổn lắm. vẫn chưa đáp ứng được yêu cầu của đề bài