Tự động điều chỉnh độ cao của dòng

Liên hệ QC
Vâng Cám ơn Anh, Em xem qua thì thấy
1. Đoạn code dài thì được đưa vào module của cả file
2. Đoạn code ngắn thì đưa vào sheet nào muốn điều chỉnh độ cao của dòng
Đúng k ạ!
Cái này người ta gọi là học từ trên ngọn học xuống gốc nè :p:p:p
 
E mới hi nên mong các Anh chị chỉ bảo và giúp đỡ hi
Bài đã được tự động gộp:


Hi E cám ơn

Anh toàn sài cái này! em thử xem có sướng không?
Mã:
'FIX ROW CO DAN DÒNG
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 * 1.15 'Chiêu` cao dòng khi fix sang 2 dòng
            .RowHeight = FirstCellHeight
    End With
ExitSub:
End Sub

Sub CoDanRowBB()
    MergeCellFit Sheets("BBan").Range("E14") '<< dòng cần fix
End Sub
 
Anh toàn sài cái này! em thử xem có sướng không?
Mã:
'FIX ROW CO DAN DÒNG
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 * 1.15 'Chiêu` cao dòng khi fix sang 2 dòng
            .RowHeight = FirstCellHeight
    End With
ExitSub:
End Sub

Sub CoDanRowBB()
    MergeCellFit Sheets("BBan").Range("E14") '<< dòng cần fix
End Sub
Cám ơn Anh, báo lỗi A ơi
 

File đính kèm

  • 2341.jpg
    2341.jpg
    224 KB · Đọc: 50
Cám ơn Anh, báo lỗi A ơi
@@!
Sub CoDanRowBB()
MergeCellFit Sheets([BGCOLOR=rgb(226, 80, 65)]"BBan"[/BGCOLOR]).Range([BGCOLOR=rgb(226, 80, 65)]"E14"[/BGCOLOR]) '<< dòng cần fix
End Sub

Sheets([BGCOLOR=rgb(226, 80, 65)]"BBan"[/BGCOLOR]) đổi thành Sheets("DANH MUC HSNT")
Còn Range("E14") là dòng cần tự động dãn, thay đổi dòng nào mà bạn cần
vd:
Sub CoDanRowBB()
MergeCellFit Sheets("DANH MUC HSNT").Range("B10")
MergeCellFit Sheets("DANH MUC HSNT").Range("B12")
MergeCellFit Sheets("DANH MUC HSNT").Range("B14")
End Sub
 
@@!
Sub CoDanRowBB()
MergeCellFit Sheets([BGCOLOR=rgb(226, 80, 65)]"BBan"[/BGCOLOR]).Range([BGCOLOR=rgb(226, 80, 65)]"E14"[/BGCOLOR]) '<< dòng cần fix
End Sub

Sheets([BGCOLOR=rgb(226, 80, 65)]"BBan"[/BGCOLOR]) đổi thành Sheets("DANH MUC HSNT")
Còn Range("E14") là dòng cần tự động dãn, thay đổi dòng nào mà bạn cần
vd:
Sub CoDanRowBB()
MergeCellFit Sheets("DANH MUC HSNT").Range("B10")
MergeCellFit Sheets("DANH MUC HSNT").Range("B12")
MergeCellFit Sheets("DANH MUC HSNT").Range("B14")
End Sub
Anh ơi em bỏ luôn cái phần đầu thế là hết lỗi ạ
PHP:
Sub CoDanRowBB()
    MergeCellFit Range("E14") '<< dòng cần fix
End Sub
 
Tôi gữi file lên luôn đây! Trong file hảy nhập text vào các cell màu vàng... (Nói chung là cell nào đã dc merge)
File này vẫn còn lỗi, nhờ các cao thủ sửa giúp (ví dụ xóa dử liệu trong cell sẽ lỗi)
ANH TUẤN
Code này khi thêm nội dung vào thì tự giãn để vừa chiều cao dòng nhưng khi xóa đi hình như chiều cao dòng không bị giảm xuống để căn vừa nội dung (chỉ có tăng lên mà không giảm chiều cao dòng xuống được)
 
code nay thi file chạy được nhưng mỗi lần change thì toàn bộ file dãn ngang như từ khổ giấy đứng chuyển qua nằm rồi bình thường lại
 
Chào cả nhà!
Hiện tại các code trên mình thấy nó đáp ứng được khi thực hiện các thảo tác bằng cách clic chuột. Giờ kết hợp với in tự động thì không thực hiên được. Mong mọi người giúp.
 
Chào cả nhà!
Hiện tại các code trên mình thấy nó đáp ứng được khi thực hiện các thảo tác bằng cách clic chuột. Giờ kết hợp với in tự động thì không thực hiên được. Mong mọi người giúp.
Bạn thử phương án, với sub sự kiện event

Private Sub Worksheet_Calculate()

End Sub

sẽ có thể giải quyết được
 
Web KT
Back
Top Bottom