Office常用函数

Excel常用函数

一、检查第一个字符是否是A，如果是，它返回“Yes”，否则返回”No“。

=IF(LEFT(A2, 1)="A", "Yes", "No")

二、Excel 拆分工作表

Private Sub 分拆工作表()
    Dim sht As Worksheet
    Dim MyBook As Workbook
    Dim NewBook As Workbook
    Set MyBook = ActiveWorkbook
    Application.ScreenUpdating = False ' 关闭屏幕更新以提高性能
    
    For Each sht In MyBook.Sheets
        sht.Copy
        Set NewBook = ActiveWorkbook ' 明确引用新工作簿
        NewBook.SaveAs Filename:=MyBook.Path & "\" & sht.Name & ".xlsx", FileFormat:=xlOpenXMLWorkbook ' 保存为.xlsx格式
        NewBook.Close False ' 关闭新工作簿，不保存更改（因为已经保存过了）
    Next sht
    
    Application.ScreenUpdating = True ' 恢复屏幕更新
    MsgBox "文件已经被分拆完毕!"
End Sub

Word常用函数

一、选择文档中所有表格

Sub SelectAllTables()
     Dim mytable As Table
      Application.ScreenUpdating = False
      For Each mytable In ActiveDocument.Tables
         mytable.Range.Editors.Add wdEditorEveryone
     Next
    ActiveDocument.SelectAllEditableRanges (wdEditorEveryone)
    ActiveDocument.DeleteAllEditableRanges (wdEditorEveryone)
     Application.ScreenUpdating = True
End Sub

二、删除文档中所有超链接

Sub RemoveHyperlinksImproved()
    Dim hyperlink As Hyperlink
    Application.ScreenUpdating = False ' 关闭屏幕更新以提高性能
    On Error GoTo ErrorHandler ' 添加错误处理
    
    ' 遍历并删除所有超链接
    For Each hyperlink In ActiveDocument.Hyperlinks
        hyperlink.Delete
    Next hyperlink
    
    ' 保存文档（可选，如果需要）
    ' ActiveDocument.Save
    
    Application.ScreenUpdating = True ' 恢复屏幕更新
    Exit Sub ' 正常退出
    
ErrorHandler:
    ' 错误处理代码
    MsgBox "发生错误: " & Err.Description, vbCritical
    Application.ScreenUpdating = True ' 确保即使发生错误也恢复屏幕更新
End Sub

三、按页拆分word文件

Option Explicit
Sub DynamicSplitPagesAsDocuments()
    Dim oSrcDoc As Document, oNewDoc As Document
    Dim strSrcName As String, strNewName As String
    Dim oRange As Range
    Dim nIndex As Integer, nSubIndex As Integer, nTotalPages As Integer, nBound As Integer
    Dim fso As Object
    Const nSteps = 2 ' 设置分割步长2表示每2页生成一个新word文件
    
    ' 关闭屏幕更新以提高性能
    Application.ScreenUpdating = False
    
    ' 创建文件系统对象
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 获取源文档
    Set oSrcDoc = ActiveDocument
    
    ' 获取总页数
    nTotalPages = oSrcDoc.ComputeStatistics(wdStatisticPages)
    
    ' 遍历源文档的每一页，按步长分割
    For nIndex = 1 To nTotalPages Step nSteps
        ' 创建新文档
        Set oNewDoc = Documents.Add
        
        ' 计算分割的边界
        If nIndex + nSteps - 1 > nTotalPages Then
            nBound = nTotalPages
        Else
            nBound = nIndex + nSteps - 1
        End If
        
        ' 复制并粘贴页面到新文档
        For nSubIndex = nIndex To nBound
            ' 复制当前页面
            oSrcDoc.Bookmarks("\page").Range.Copy
            
            ' 粘贴到新文档
            oNewDoc.Content.Paste
            
            ' 切换到下一页（源文档）
            Application.Browser.Target = wdBrowsePage
            Application.Browser.Next
        Next nSubIndex
        
        ' 添加页码和总页数到页脚
        With oNewDoc.Sections(1).Footers(wdHeaderFooterPrimary).Range
            .Collapse wdCollapseEnd
            .InsertAfter vbCrLf ' 添加换行以分隔页码和文本（可选）
            .Collapse wdCollapseEnd
            .Fields.Add Range:=.Duplicate, Type:=wdFieldPage, Text:="Page "
            .Collapse wdCollapseEnd
            .InsertAfter " / "
            .Fields.Add Range:=.Duplicate, Type:=wdFieldNumPages, Text:=" of "
            .Fields.Update
            .ParagraphFormat.Alignment = wdAlignParagraphCenter
        End With
        
        ' 构建并保存新文档的文件名
        strSrcName = oSrcDoc.FullName
        strNewName = fso.BuildPath(fso.GetParentFolderName(strSrcName), _
            fso.GetBaseName(strSrcName) & "_20240" & (nIndex \ nSteps + 1) & "." & fso.GetExtensionName(strSrcName))
        oNewDoc.SaveAs2 FileName:=strNewName, FileFormat:=wdFormatXMLDocument ' 使用SaveAs2方法，并指定文件格式，strNewName 表示新生成word文件的文件名
        oNewDoc.Close False
    Next nIndex
    
    ' 清理对象
    Set oNewDoc = Nothing
    Set oSrcDoc = Nothing
    Set fso = Nothing
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
    
    ' 显示完成消息
    MsgBox "结束!"
End Sub

四、将所有文本框中的内容转换成文本

Sub RemoveTextBox2()
    Dim shp As Shape
    Dim oRngAnchor As Range
    Dim sString As String
    For Each shp In ActiveDocument.Shapes
        If shp.Type = msoTextBox Then
            ' copy text to string, without last paragraph mark
            sString = Left(shp.TextFrame.TextRange.Text, _
              shp.TextFrame.TextRange.Characters.Count - 1)
            If Len(sString) > 0 Then
                ' set the range to insert the text
                Set oRngAnchor = shp.Anchor.Paragraphs(1).Range
                ' insert the textbox text before the range object
                oRngAnchor.InsertBefore _
                  "" & sString & ""
            End If
            shp.delete
        End If
    Next shp
End Sub