Cho em xin code tự động thay đổi chiều cao của dòng
- Thread starter tn001
- Ngày gửi
Em có đoạn code tìm được trên net nhưng chưa biết cách ứng dụng. Mong các anh các chị giúp đỡ em với
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MergeWidth As Single
Dim cM As Range
Dim AutoFitRng As Range
Dim CWidth As Double
Dim NewRowHt As Double
Dim str01 As String
str01 = "Name"
If Not Intersect(Target, Range(str01)) Is Nothing Then
Application.ScreenUpdating = False
On Error Resume Next
Set AutoFitRng = Range(Range(str01).MergeArea.Address)
With AutoFitRng
.MergeCells = False
CWidth = .Cells(1).ColumnWidth
MergeWidth = 0
For Each cM In AutoFitRng
cM.WrapText = True
MergeWidth = cM.ColumnWidth + MergeWidth
Next
'small adjustment to temporary width
MergeWidth = MergeWidth + AutoFitRng.Cells.Count * 0.66
.Cells(1).ColumnWidth = MergeWidth
.EntireRow.AutoFit
NewRowHt = .RowHeight
.Cells(1).ColumnWidth = CWidth
.MergeCells = True
.RowHeight = NewRowHt
End With
Application.ScreenUpdating = True
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MergeWidth As Single
Dim cM As Range
Dim AutoFitRng As Range
Dim CWidth As Double
Dim NewRowHt As Double
Dim str01 As String
str01 = "Name"
If Not Intersect(Target, Range(str01)) Is Nothing Then
Application.ScreenUpdating = False
On Error Resume Next
Set AutoFitRng = Range(Range(str01).MergeArea.Address)
With AutoFitRng
.MergeCells = False
CWidth = .Cells(1).ColumnWidth
MergeWidth = 0
For Each cM In AutoFitRng
cM.WrapText = True
MergeWidth = cM.ColumnWidth + MergeWidth
Next
'small adjustment to temporary width
MergeWidth = MergeWidth + AutoFitRng.Cells.Count * 0.66
.Cells(1).ColumnWidth = MergeWidth
.EntireRow.AutoFit
NewRowHt = .RowHeight
.Cells(1).ColumnWidth = CWidth
.MergeCells = True
.RowHeight = NewRowHt
End With
Application.ScreenUpdating = True
End If
End Sub
Upvote
0
- Tham gia
- 5/6/08
- Bài viết
- 30,703
- Được thích
- 53,947
Xem bài này:
http://www.giaiphapexcel.com/forum/showthread.php?6773-Tự-động-điều-chỉnh-độ-cao-của-dòng
Toàn bộ code cho vào sheet mà bạn muốn chỉnh
Upvote
0
Em cảm ơn anh nhiều! về cơ bản là em đã đạt được mong muốn. Em muốn hỏi thêm một chút là trong sheet em chỉ muốn nó có tác động đến một số dòng đã định trước, không phải là tất cả các dòng thì làm như thế nào ạ?
Xin cảm ơn anh nhiều!
Upvote
0
- Tham gia
- 5/6/08
- Bài viết
- 30,703
- Được thích
- 53,947
Đoạn code này:
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
Call AutoFitMergedCellRowHeight(Target)
End Sub
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("[COLOR=#ff0000][B]gì gì đó[/B][/COLOR]"), Target) is Nothing then
If Target.Count = 1 then Call AutoFitMergedCellRowHeight(Target)
End If
End Sub
Upvote
0
Bạn hãy thay sub AutoFitMergedCellRowHeight của bạn bằng sub AutoFitMergedCellRowHeight của tôi xem
Mã:
Sub AutoFitMergedCellRowHeight(Target As Range)
Dim NewRwHt As Single
Dim cWdth As Single, MrgeWdth As Single
Dim c As Range, cc As Range
Dim ma As Range
With Target
If .MergeCells And .WrapText Then
Set c = Target.Cells(1, 1)
cWdth = c.ColumnWidth
Set ma = c.MergeArea
For Each cc In ma.Cells
MrgeWdth = MrgeWdth + cc.ColumnWidth
Next
Application.ScreenUpdating = False
ma.MergeCells = False
c.ColumnWidth = MrgeWdth
c.EntireRow.AutoFit
NewRwHt = c.RowHeight
c.ColumnWidth = cWdth
ma.MergeCells = True
ma.RowHeight = NewRwHt
cWdth = 0: MrgeWdth = 0
Application.ScreenUpdating = True
End If
End With
End Sub
Upvote
0
Vẫn chưa được các anh ơi. Các anh xem lại hộ em nhé, vấn đề của em ghi rõ lại ở file autofix1 rồi. Em xin cảm ơn ạ!
Upvote
0
- Tham gia
- 17/8/08
- Bài viết
- 8,662
- Được thích
- 16,718
- Giới tính
- Nam
Cần gì code nhiều cho mệt, tại môi trường VBA của sheet1 bạn đặt thủ tục sau vào module của sheet đó như sau:
Mã:
Private Sub Worksheet_Activate()
Range("C7").EntireRow.AutoFit
End SubRồi bây giờ bạn có thể thay đổi gì đó tại ô C12 của Sheet2, và quay lại thử xem sao!
Lần chỉnh sửa cuối:
Upvote
0
Tôi không biết bạn làm như thế nào mà lại ra như thế.
Bạn hãy test theo 3 kiểu:
1. Bạn xóa nội dung của C7 --> viết test dài dài --> ENTER --> ô sẽ vừa khít với text
Bây giờ bạn lại chọn C7 --> xóa bớt text --> ENTER --> ô sẽ co lại vừa khít với text
2. Tôi để ý thấy bạn nhập công thức cho ô C7. Vậy bạn:
chọn C7 --> xóa text trong C7 --> gõ trên thanh công thức: =Sheet2!C12 --> ENTER
Chắc chắn ô C7 sẽ co lại vừa khít với text
Chú ý: Sub AutoFitMergedCellRowHeight chỉ được gọi khi có Worksheet_Change, tức text trong ô thay đổi.
3. Trong file của bạn hiện thời ô C7 không co lại (tôi không biết bạn thao tác thế nào). Nếu bạn click vào C7 rồi ENTER thì C7 vẫn thế. Nếu bạn double click vào C7 rồi ENTER thì C7 sẽ co lại.
---------------
Nếu bạn có công thức ở Sheet1!C7 là =Sheet 2!C12 thì khi bạn thay đổi độ dài của text trong Sheet2!C12 thì ô C7 không tự co lại vì Worksheet_Change của Sheet1 không sẩy ra, vậy AutoFitMergedCellRowHeight không được gọi.
Nếu bạn muốn khi thay đổi Sheet2!C12 mà Sheet1!C7 tự co thì có nhiều cách. Vd. thêm Worksheet_Activate như bài #9
Lần chỉnh sửa cuối:
Upvote
0
- Tham gia
- 17/8/08
- Bài viết
- 8,662
- Được thích
- 16,718
- Giới tính
- Nam
Nếu muốn kỹ hơn, chỉ thay đổi độ cao của ô C7 của sheet1 khi ô C12 ở sheet2 thay đổi thì làm thủ tục sau:
Tại module của sheet2 bạn thực hiện thủ tục sau:
Bây giờ bạn gõ gì ở ô C12 thì ô C7 cũng thay đổi theo (không cần công thức) và tự động fit hàng.
Tại module của sheet2 bạn thực hiện thủ tục sau:
PHP:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$C$12" Then
With Application
.EnableEvents = False
.Calculation = xlCalculationManual
With Sheet1.Range("C7")
.Value = Target.Value
.EntireRow.AutoFit
End With
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End If
End SubBây giờ bạn gõ gì ở ô C12 thì ô C7 cũng thay đổi theo (không cần công thức) và tự động fit hàng.
Upvote
0
Dạ! Em cảm ơn các anh ạ! Nhưng mà vấn đề của em vẫn còn mắc tý chút là cái cell kết quả không phải 1 ô, mà là nhiều cell đã được Merge lại rồi ạ. các anh xem lại file autofix1 hộ em
Cell kết quả nếu chỉ là một ô thì theo các anh hướng dẫn là okie
Cell kết quả nếu chỉ là một ô thì theo các anh hướng dẫn là okie
Lần chỉnh sửa cuối:
Upvote
0
- Tham gia
- 17/8/08
- Bài viết
- 8,662
- Được thích
- 16,718
- Giới tính
- Nam
Thì bạn cứ merge thoải mái đi, từ ô C7:F7 chẳng hạn, thử chạy trên file tôi mới gửi xem sao!
Upvote
0
Em test rồi anh ạ, file autofix2 của anh, nếu mà Merge (ví dụ từ C7:F7) vẫn chưa được ạ, anh check lại giúp em với!
Upvote
0
- Tham gia
- 17/8/08
- Bài viết
- 8,662
- Được thích
- 16,718
- Giới tính
- Nam
Sorry bạn, kể cả tôi dùng thủ công đi chăng nữa thì nó cũng không thể nào FIT được khi khối ô là MERGE CELLS. Nên không thể thực hiện code trong trường hợp này được!
Nhưng có nhất thiết phải Merge không, bởi vì ta có thể co giản độ rộng của cột?
Nhưng có nhất thiết phải Merge không, bởi vì ta có thể co giản độ rộng của cột?
Upvote
0
Dạ, tại dữ liệu của em có liên quan đến bảng tính anh ah, nên phải Merge anh ah. Nếu không được thì có thể làm theo cách đếm ký tự được không anh? Ví dụ là lớn hơn x ký tự (x có thể do mình tùy chọn) để điều chỉnh độ cao của dòng?
Upvote
0
- Tham gia
- 17/8/08
- Bài viết
- 8,662
- Được thích
- 16,718
- Giới tính
- Nam
Cái code này là chữa cháy cho bạn đây, không biết bạn thấy thế nào:
PHP:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$C$12" Then
Dim w As Double, h As Double, i As Byte
With Application
.EnableEvents = False
.Calculation = xlCalculationManual
Sheet1.Range("C7").Value = Target.Value
With Sheet1.Range("C6") 'Lay o tren 1 hang
For i = 0 To 3 'Neu merge là 4 ô
w = w + .Offset(, i).ColumnWidth
Next
End With
With Sheet1.Range("IT7") 'Lay mot ô phu (cuoi sheet) lam cot trung gian
.Value = Target.Value
.ColumnWidth = w
.EntireRow.AutoFit
h = .RowHeight
.Clear
.RowHeight = h
End With
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End If
End SubTôi dùng một trong những ô cuối cùng hàng với ô C7 làm ô trung gian, sau khi xử lý hàng xong thì tôi xóa ô này đi, phần còn lại đã được giải quyết. Thử gõ vào ô C12 của sheet2 rồi mở sheet1 xem sao nhé!
Bạn thấy thế nào?
============================================
À, để đảm bảo luôn luôn đúng trong mọi trường hợp, bạn thêm vào code 1 chút xíu thủ tục .WrapText = True nhé!
Mã:
With Sheet1.Range("IT7") 'Lay mot ô phu (cuoi sheet) lam cot trung gian
.Value = Target.Value
[COLOR=#ff0000][B].WrapText = True[/B][/COLOR]
.ColumnWidth = w
.EntireRow.AutoFit
h = .RowHeight
.Clear
.RowHeight = h
End With
Lần chỉnh sửa cuối:
Upvote
0
Cảm ơn rất nhiều vì sự nhiệt tình của anh. Em test thử rồi, code ngon lành anh ah. Thanks anh nhiều nhé!!!!!!!
Lần chỉnh sửa cuối:
Upvote
0
- Tham gia
- 17/8/08
- Bài viết
- 8,662
- Được thích
- 16,718
- Giới tính
- Nam
Bạn bị ngăn sự kiện rồi!
Trong VBA, bạn bấm Ctrl+G để mở cửa sổ Immediate, sau đó bạn copy dòng này:
Application.EnableEvents = True
Rồi đặt con trỏ vô dòng lệnh đó rồi bấm nút Enter. Thực hiện xong thì bạn thử làm gì đó trên ô C12 xem sao!
Upvote
0
Ngon, quá ngon anh ah. Em cảm ơn anh rất nhiều ạ.
Chúc anh sức khỏe, hạnh phúc và thành công!
Upvote
0
Bài viết mới nhất
- Question
- Question
