请求各位帮忙！懂macro的进！

[garcon1986]

大家好，

我在对文件筛选后，合并单元格里不用双击就能完全显示里面的内容。使用自适应行高没有任何作用。所以，我就想用宏来实现，可我vba刚刚入门，完全没有什么思路，请大家帮帮忙啊。感激不尽！！！


发不了附件，请大家看帖：http://club.excelhome.net/thread-507579-1-1.html


代码如下：

Sub AutoFitMergedCellRowHeight()
    Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
    Dim CurrCell As Range
    Dim ActiveCellWidth As Single, PossNewRowHeight As Single
    Dim StartCell As Range, c As Range, MergeRng As Range, Cell As Range
    Dim a() As String, isect As Range, i

    
'Take a note of current active cell
Set StartCell = ActiveCell

'Create an array of merged cell addresses that have wrapped text
For Each c In ActiveSheet.UsedRange
If c.MergeCells Then
    With c.MergeArea
    If .Rows.Count = 1 And .WrapText = True Then
        If MergeRng Is Nothing Then
            Set MergeRng = c.MergeArea
            ReDim a(0)
            a(0) = c.MergeArea.Address
        Else
        Set isect = Intersect(c, MergeRng)
            If isect Is Nothing Then
                Set MergeRng = Union(MergeRng, c.MergeArea)
                ReDim Preserve a(UBound(a) + 1)
                a(UBound(a)) = c.MergeArea.Address
            End If
        End If
    End If
    End With
End If
Next c


Application.ScreenUpdating = False

'Loop thru merged cells
For i = 0 To UBound(a)
Range(a(i)).Select
      With ActiveCell.MergeArea
            If .Rows.Count = 1 And .WrapText = True Then
                'Application.ScreenUpdating = False
                CurrentRowHeight = .RowHeight
                ActiveCellWidth = ActiveCell.ColumnWidth
                For Each CurrCell In Selection
                    MergedCellRgWidth = CurrCell.ColumnWidth + MergedCellRgWidth
                      
                      If MergedCellRgWidth > 255 Then
                            MergedCellRgWidth = 255
                      End If
                Next
                .MergeCells = False
                .Cells(1).ColumnWidth = MergedCellRgWidth
                .EntireRow.AutoFit
                PossNewRowHeight = .RowHeight
                .Cells(1).ColumnWidth = ActiveCellWidth
                .MergeCells = True
                .RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
                  CurrentRowHeight, PossNewRowHeight)
            End If
        End With
MergedCellRgWidth = 0
Next i

StartCell.Select
Application.ScreenUpdating = True

'Clean up
Set CurrCell = Nothing
Set StartCell = Nothing
Set c = Nothing
Set MergeRng = Nothing
Set Cell = Nothing

End Sub

谢谢啦。

[garcon1986]

有人吗？

[laoyebin]

列AUTOFIT应该可以的啊

[garcon1986]

[Quote=引用 2 楼 laoyebin 的回复:]
列AUTOFIT应该可以的啊
[/Quote]
试过是不行的。所以来请教大家啊。

[garcon1986]

有人吗？