Office（Excel、PPT、Word) VBA（宏）常用代码

Office官方文档：

Office 中的 VBA 入门

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

合并多个Excel文件

sub 合并当前目录下所有工作簿的全部工作表() 
dim mypath, myname, awbname 
dim wb as workbook, wbn as string 
dim g as long 
dim num as long 
dim box as string 
application.screenupdating = false 
mypath = activeworkbook.path 
myname = dir(mypath & "\" & "*.xls") 
awbname = activeworkbook.name 
num = 0 
do while myname <> "" 
if myname <> awbname then 
set wb = workbooks.open(mypath & "\" & myname) 
num = num + 1 
with workbooks(1).activesheet 
.cells(.range("a65536").end(xlup).row + 2, 1) = left(myname, len(myname) - 4) 
for g = 1 to sheets.count 
wb.sheets(g).usedrange.copy .cells(.range("a65536").end(xlup).row + 1, 1) 
next 
wbn = wbn & chr(13) & wb.name 
wb.close false 
end with 
end if 
myname = dir 
loop 
range("a1").select 
application.screenupdating = true 
msgbox "共合并了" & num & "个工作薄下的全部工作表。如下：" & chr(13) & wbn, vbinformation, "提示" 
end sub

新建一个空的excel文件，在Sheet1右键，查看代码，将VBA代码填入；回到开发工具栏，宏，执行 合并当前目录下所有工作簿的全部工作表