如何一次性将选中的单元格增减指定的行高数值

mp3_2004

求一个小程序，不管原始单元格行高多少，只要运行这个VBA程序，就能按设定的数值在原行高上增减行高，这个论坛上有类似的，但是不能只调选定单元格的行高，一调就全调了。

mp3_2004

以下这个程序，只能单行，请大神帮我修改一下，万分感谢，改成可以多行同时调整的

Sub 批量增减行高()
    Dim h, rng As Range, cel As Range, Area As Range, nh As Single, RngAdr$, tmp, i&
    h = InputBox("请输入行高增量值", "批量增加选定区域的行高")
    h = Val(h)
    If h = 0 Then Exit Sub
    RngAdr = "," & ActiveWindow.RangeSelection.EntireRow.Address
    tmp = Split(RngAdr, ",")
    Set rng = Range(tmp(1))
    For i = 2 To UBound(tmp)
        Set rng = Union(rng, Range(tmp(i)))
    Next
    Set rng = rng.Rows
    Application.ScreenUpdating = False
    For Each Area In rng.Areas
        For Each cel In Area.Columns(1)
            nh = cel.RowHeight + h
            If nh < 0 Then nh = 0
            cel.RowHeight = nh
        Next
    Next
End Sub

mp3_2004

这个只能单行调整，Sub 批量增减行高()     Dim h, rng As Range, cel As Range, Area As Range, nh As Single, RngAdr$, tmp, i&     h = InputBox("请输入行高增量值", "批量增加选定区域的行高")     h = Val(h)     If h = 0 Then Exit Sub     RngAdr = "," & ActiveWindow.RangeSelection.EntireRow.Address     tmp = Split(RngAdr, ",")     Set rng = Range(tmp(1))     For i = 2 To UBound(tmp)         Set rng = Union(rng, Range(tmp(i)))     Next     Set rng = rng.Rows     Application.ScreenUpdating = False     For Each Area In rng.Areas         For Each cel In Area.Columns(1)             nh = cel.RowHeight + h             If nh < 0 Then nh = 0             cel.RowHeight = nh         Next     Next End Sub

mp3_2004

已从别的网上找到适用代码