怎么判断单元格内容没有完全显示，并自动调整行高？（有合并单元格）

星河中的一粒沙

对合并单元格这个问题是不是无解？

ykcbf1100

设置为自动行高和自动列宽

yuyubiao

从外国人那里抄回来的，你看一下。

1. Sub 调整合并单元格高度()
   
2.    
   
3.    
   
4.     Dim j As Long
   
5.     Dim n As Long
   
6.     Dim i As Long
   
7.     Dim MW As Double 'merge width
   
8.     Dim RH As Double 'row height
   
9.     Dim MaxRH As Double
   
10.     Dim rngMArea As Range
    
11.     Dim rng As Range
    
12.    
    
13.     Const SpareCol  As Long = 26
    
14.     Set rng = Range("a1:m68" & _
    
15.         Range("A" & Rows.Count).End(xlUp).row)
    
16.    
    
17.     With rng
    
18.         For j = 1 To .Rows.Count
    
19.             'if the row is not hidden
    
20.             If Not .Parent.Rows(.Cells(j, 1).row) _
    
21.                 .Hidden Then
    
22.                 'if the cells have data
    
23.                 If Application.WorksheetFunction _
    
24.                     .CountA(.Rows(j)) Then
    
25.                     MaxRH = 0
    
26.                     For n = .Columns.Count To 1 Step -1
    
27.                         If Len(.Cells(j, n).value) Then
    
28.                             'mergecells
    
29.                             If .Cells(j, n).MergeCells Then
    
30.                                 Set rngMArea = _
    
31.                                     .Cells(j, n).MergeArea
    
32.                                 With rngMArea
    
33.                                     MW = 0
    
34.                                     If .WrapText Then
    
35.                                         'get the total width
    
36.                                         For i = 1 To .Cells.Count
    
37.                                             MW = MW + _
    
38.                                                 .Columns(i).ColumnWidth
    
39.                                         Next
    
40.                                         MW = MW + .Cells.Count * 0.66
    
41.                                         'use the spare column
    
42.                                         'and put the value,
    
43.                                         'make autofit,
    
44.                                         'get the row height
    
45.                                         With .Parent.Cells(.row, SpareCol)
    
46.                                             .value = rngMArea.value
    
47.                                             .ColumnWidth = MW
    
48.                                             .WrapText = True
    
49.                                             .EntireRow.AutoFit
    
50.                                             RH = .RowHeight
    
51.                                             MaxRH = Application.Max(RH, MaxRH)
    
52.                                             .value = vbNullString
    
53.                                             .WrapText = False
    
54.                                             .ColumnWidth = 8.43
    
55.                                         End With
    
56.                                         .RowHeight = MaxRH
    
57.                                     End If
    
58.                                 End With
    
59.                             ElseIf .Cells(j, n).WrapText Then
    
60.                                 RH = .Cells(j, n).RowHeight
    
61.                                 .Cells(j, n).EntireRow.AutoFit
    
62.                                 If .Cells(j, n).RowHeight < RH Then _
    
63.                                     .Cells(j, n).RowHeight = RH
    
64.                             End If
    
65.                         End If
    
66.                     Next
    
67.                 End If
    
68.             End If
    
69.         Next
    
70.         .Parent.Parent.Worksheets(.Parent.Name).UsedRange
    
71.     End With
    
72.     Set rng = Nothing
    
73. End Sub

复制代码

huanghai22

演示用~~~~~

星河中的一粒沙

huanghai22 发表于 2023-4-27 17:51
演示用~~~~~

看着不错，怎么实现的啊？有代码没亲

星河中的一粒沙

ykcbf1100 发表于 2023-4-27 16:54
设置为自动行高和自动列宽

这个办法不好使啊

perfect131

星河中的一粒沙 发表于 2023-4-27 18:45
这个办法不好使啊

这样
https://club.excelhome.net/threa ... tml?_dsign=953d5959