VBA代码

Word VBA

Excel VBA

操作word

' 声明 Word 应用程序对象
Dim wordApp As Object

' 初始化 Word 应用程序
Sub InitializeWordApp()
    On Error Resume Next
    Set wordApp = CreateObject("Word.Application")
    wordApp.Visible = False ' 设置 Word 不可见，避免干扰
End Sub

' 关闭 Word 应用程序
Sub CloseWordApp()
    On Error Resume Next
    wordApp.Quit
    Set wordApp = Nothing
End Sub

' 获取或打开 Word 文档
Function GetOrOpenWordDocument(filePath As String) As Object
    On Error Resume Next
    Dim doc As Object
    
    ' 如果 Word 应用程序未初始化，则初始化
    If wordApp Is Nothing Then
        Call InitializeWordApp
    End If
    
    ' 如果文件路径不为空，则尝试打开文档
    If filePath <> "" Then
        ' 检查文档是否已经打开
        On Error Resume Next
        Set doc = wordApp.Documents(filePath)
        On Error GoTo 0
        
        ' 如果文档未打开，则尝试打开
        If doc Is Nothing Then
            Set doc = wordApp.Documents.Open(filePath)
        End If
    Else
        ' 如果文件路径为空，则创建一个新文档
        Set doc = wordApp.Documents.Add
    End If
    
    Set GetOrOpenWordDocument = doc
End Function

' 查找文本
Function FindTextInWord(doc As Object, searchText As String) As Boolean
    On Error Resume Next
    FindTextInWord = doc.Content.Find.Execute(FindWhat:=searchText, MatchCase:=False, MatchWholeWord:=False)
End Function

' 写入文本
Sub WriteTextToWord(doc As Object, text As String)
    On Error Resume Next
    doc.Content.InsertAfter text & vbNewLine
End Sub

' 读取表格内容
Function ReadTableFromWord(doc As Object, tableIndex As Integer, row As Integer, column As Integer) As String
    On Error Resume Next
    If doc.Tables.Count >= tableIndex Then
        ReadTableFromWord = doc.Tables(tableIndex).Cell(row, column).Range.Text
        ' 去掉多余的换行符
        ReadTableFromWord = Trim(Left(ReadTableFromWord, Len(ReadTableFromWord) - 2))
    Else
        ReadTableFromWord = ""
    End If
End Function

' 写入表格数据
Sub WriteTableDataToWord(doc As Object, tableIndex As Integer, row As Integer, column As Integer, data As String)
    On Error Resume Next
    If doc.Tables.Count >= tableIndex Then
        doc.Tables(tableIndex).Cell(row, column).Range.Text = data
    End If
End Sub

' 设置表格样式
Sub SetTableStyleInWord(doc As Object, tableIndex As Integer, styleName As String)
    On Error Resume Next
    If doc.Tables.Count >= tableIndex Then
        doc.Tables(tableIndex).Style = styleName
    End If
End Sub

' 示例：从 Word 文档中提取表格数据到 Excel
Sub ExampleExtractWordTableDataToExcel()
    Dim filePath As String
    Dim doc As Object
    Dim ws As Worksheet
    Dim tableIndex As Integer
    Dim rowNumber As Integer
    Dim cellContent As String
    
    ' 设置文件路径
    filePath = "C:\路径\到\你的\文件\a.docx" ' 修改为实际的文件路径
    
    ' 获取或打开 Word 文档
    Set doc = GetOrOpenWordDocument(filePath)
    If doc Is Nothing Then
        MsgBox "无法获取或打开 Word 文档！", vbExclamation
        Exit Sub
    End If
    
    ' 设置目标工作表为 Sheet1
    Set ws = ThisWorkbook.Sheets("Sheet1")
    rowNumber = 1 ' 初始化行号，从第一行开始写入
    
    ' 遍历第 7 到第 19 个表格
    For tableIndex = 7 To 19
        cellContent = ReadTableFromWord(doc, tableIndex, 1, 2)
        If cellContent <> "" Then
            ws.Cells(rowNumber, 1).Value = cellContent
            rowNumber = rowNumber + 1
        End If
    Next tableIndex
    
    ' 关闭 Word 文档（如果需要）
    ' doc.Close False
    
    MsgBox "数据提取完成！", vbInformation
End Sub

' 示例：向 Word 文档中写入表格数据
Sub ExampleWriteTableDataToWord()
    Dim filePath As String
    Dim doc As Object
    Dim ws As Worksheet
    Dim tableIndex As Integer
    Dim row As Integer
    Dim column As Integer
    Dim data As String
    
    ' 设置文件路径
    filePath = "C:\路径\到\你的\文件\a.docx" ' 修改为实际的文件路径
    
    ' 获取或打开 Word 文档
    Set doc = GetOrOpenWordDocument(filePath)
    If doc Is Nothing Then
        MsgBox "无法获取或打开 Word 文档！", vbExclamation
        Exit Sub
    End If
    
    ' 设置目标工作表为 Sheet1
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ' 设置表格索引、行、列和数据
    tableIndex = 1
    row = 1
    column = 2
    data = "新内容"
    
    ' 写入表格数据
    Call WriteTableDataToWord(doc, tableIndex, row, column, data)
    
    ' 保存并关闭 Word 文档
    doc.Save
    ' doc.Close False
    
    MsgBox "数据写入完成！", vbInformation
End Sub

' 示例：设置 Word 文档中表格样式
Sub ExampleSetTableStyleInWord()
    Dim filePath As String
    Dim doc As Object
    Dim tableIndex As Integer
    Dim styleName As String
    
    ' 设置文件路径
    filePath = "C:\路径\到\你的\文件\a.docx" ' 修改为实际的文件路径
    
    ' 获取或打开 Word 文档
    Set doc = GetOrOpenWordDocument(filePath)
    If doc Is Nothing Then
        MsgBox "无法获取或打开 Word 文档！", vbExclamation
        Exit Sub
    End If
    
    ' 设置表格索引和样式名称
    tableIndex = 1
    styleName = "表格式 专业型"
    
    ' 设置表格样式
    Call SetTableStyleInWord(doc, tableIndex, styleName)
    
    ' 保存并关闭 Word 文档
    doc.Save
    ' doc.Close False
    
    MsgBox "表格样式设置完成！", vbInformation
End Sub