Office官方文档:
Office 2016 中 VBA 的新增功能
Excel合并单元格的自动调整行高
当有合并单元格的时候,自动调整行高失效,这时可用如下代码:
Sub My_MergeCell_AutoHeight()
Dim rh As Single, mw As Single
Dim rng As Range, rrng As Range, n1%, n2%
Dim aw As Single, rh1 As Single
Dim m$, n$, k
Dim ir1, ir2, ic1, ic2
Dim mySheet As Worksheet
Dim selectedA As Range
Dim wrkSheet As Worksheet
Application.ScreenUpdating = False
Set mySheet = ActiveSheet
On Error Resume Next
Err.Number = 0
Set selectedA = Application.Intersect(ActiveWindow.RangeSelection, mySheet.UsedRange)
selectedA.Activate
If Err.Number <> 0 Then
g = MsgBox("请先选择需要'最合适行高'的行!", vbInformation)
Return
End If
selectedA.EntireRow.AutoFit
Set wrkSheet = ActiveWorkbook.Worksheets.Add
For Each rrng In selectedA
If rrng.Address <> rrng.MergeArea.Address Then
If rrng.Address = rrng.MergeArea.Item(1).Address Then
Dim tempCell As Range
Dim width As Double
Dim tempcol
width = 0
For Each tempcol In rrng.MergeArea.Columns
width = width + tempcol.ColumnWidth
Next
wrkSheet.Columns(1).WrapText = True
wrkSheet.Columns(1).ColumnWidth = width
wrkSheet.Columns(1).Font.Size = rrng.Font.Size
wrkSheet.Cells(1, 1).Value = rrng.Value
wrkSheet.Activate
wrkSheet.Cells(1, 1).RowHeight = 0
wrkSheet.Cells(1, 1).EntireRow.Activate
wrkSheet.Cells(1, 1).EntireRow.AutoFit
mySheet.Activate
rrng.Activate
If (rrng.RowHeight < wrkSheet.Cells(1, 1).RowHeight) Then
Dim tempHeight As Double
Dim tempCount As Integer
tempHeight = wrkSheet.Cells(1, 1).RowHeight
tempCount = rrng.MergeArea.Rows.Count
For Each addHeightRow In rrng.MergeArea.Rows
If (addHeightRow.RowHeight < tempHeight / tempCount) Then
addHeightRow.RowHeight = tempHeight / tempCount
End If
tempHeight = tempHeight - addHeightRow.RowHeight
tempCount = tempCount - 1
Next
End If
End If
End If
Next
Application.DisplayAlerts = False '删除工作表警告提示去消
wrkSheet.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.OnUndo "撤销'合并单元格根据内容增高'操作", "Undo_My_MergeCell_AutoHeight"
End Sub
PPT一键修改全部字体
Sub 修改全文字体颜色()
Dim oShape As Shape
Dim oSlide As Slide
Dim oTxtRange As TextRange
On Error Resume Next
For Each oSlide In ActivePresentation.Slides
For Each oShape In oSlide.Shapes
Set oTxtRange = oShape.TextFrame.TextRange
If Not IsNull(oTxtRange) Then
With oTxtRange.Font
.Name = "楷体_GB2312" '更改为需要的字体
.Size = 15 '改为所需的文字大小
.Bold = False '取消加粗
.Color.RGB = RGB(Red:=255, Green:=120, Blue:=0) '改成想要的文字颜色,用RGB参数表示
End With
End If
Next
Next
End Sub