我的目标是合并单元格的高度自动调整到其内容。这适用于具有这段代码的一个单元格:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim h, rng As Range
Set rng = Selection
If ActiveCell.MergeCells Then
With ActiveCell.MergeArea
If .WrapText = True Then
With rng
.UnMerge
.Cells(1).EntireRow.AutoFit
h = .Cells(1).RowHeight
.Merge
.EntireRow.AutoFit
With .Cells(1).MergeArea
.Cells(.Cells.Count).RowHeight = (h - .Height + 14.25)
End With
End With
End If
End With
End If
End Sub
但是,如果我在同一行中有两个单元格并且第二个单元格较短,则它会调整为第二个单元格。(请参见下面的示例)
关于如何解决这个问题的任何想法,以便它只在同一行中没有更高高度的单元格时进行调整?
这是一个更新的版本。顺便提一句。单元格都在同一列(AS 和 AU)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
If ActiveCell.MergeCells Then
Dim heigtAS, heightAU As Integer
'AS-Block
Dim hAS, rngAS As Range
Set rngAS = Range("AS10:AS18")
With rngAS.MergeArea
If .WrapText = True Then
With rngAS
.UnMerge
.Cells(1).EntireRow.AutoFit
hAS = .Cells(1).RowHeight
.Merge
.EntireRow.AutoFit
With .Cells(1).MergeArea
heightAS = (hAS - .Height + 14.25)
'save height of cell
End With
End With
End If
End With
'AU-Block
Dim hAU, rngAU As Range
Set rngAU = Range("AU10:AU18")
With rngAU.MergeArea
If .WrapText = True Then
With rngAU
.UnMerge
.Cells(1).EntireRow.AutoFit
hAU = .Cells(1).RowHeight
.Merge
.EntireRow.AutoFit
With .Cells(1).MergeArea
heightAU = (hAU - .Height + 14.25)
'save height of cell
End With
End With
End If
End With
'Compare height and fit cell height
If heightAS > heightAU Then
.Cells(.Cells.Count).RowHeight = heightAS
Else
.Cells(.Cells.Count).RowHeight = heightAU
End If
End If
End Sub
我莫名其妙无法让它工作......