在word中利用vba写代码，要求如下：1、查找多个单词；2、对找到的单词设置红色底纹；3、返回底纹所在的页码

可以使用VBA代码实现上述要求。VBA代码如下：Sub FindWord()Dim strFind As String, strReplace As String '定义字符串变量Dim Rng As Range '定义Range变量strFind = InputBox("请输入要查找的单词：", "FindWord") '输入查找字符Set Rng = ActiveDocument.Content '查找范围With Rng.Find.ClearFormatting '清除查找格式.Text = strFind '设置查找字符.Replacement.ClearFormatting '清除替换格式.Replacement.Font.Shading.BackgroundPatternColor = wdColorRed '设置颜色.Execute Replace:=wdReplaceAll '执行查找End WithMsgBox "完成！页码：" & ActiveDocument.ComputeStatistics(wdStatisticPages), vbInformation, "FindWord"End Sub

相关问题

写一个VBA代码，要求如下：将一个Excel表格上的数据拆分到其他两个Excel表中

以下是一个示例VBA代码，可以将Excel表格中的数据拆分到两个新的Excel表中。在这个示例中，我们将假设原始表格的名称为“Sheet1”，第一个新表格的名称为“NewSheet1”，第二个新表格的名称为“NewSheet2”。

Sub SplitData()
    Dim srcSheet As Worksheet
    Dim newSheet1 As Worksheet
    Dim newSheet2 As Worksheet
    
    Set srcSheet = ThisWorkbook.Worksheets("Sheet1")
    Set newSheet1 = ThisWorkbook.Worksheets.Add(After:=srcSheet)
    newSheet1.Name = "NewSheet1"
    Set newSheet2 = ThisWorkbook.Worksheets.Add(After:=newSheet1)
    newSheet2.Name = "NewSheet2"
    
    Dim srcData() As Variant
    srcData = srcSheet.UsedRange.Value
    
    Dim newData1() As Variant
    ReDim newData1(1 To UBound(srcData), 1 To 3)
    
    Dim newData2() As Variant
    ReDim newData2(1 To UBound(srcData), 1 To 3)
    
    Dim i As Long
    Dim j As Long
    Dim k As Long
    
    For i = 1 To UBound(srcData)
        If srcData(i, 1) = "A" Then
            k = k + 1
            For j = 1 To 3
                newData1(k, j) = srcData(i, j)
            Next j
        Else
            k = k + 1
            For j = 1 To 3
                newData2(k, j) = srcData(i, j)
            Next j
        End If
    Next i
    
    newSheet1.Range("A1:C" & k).Value = newData1
    newSheet2.Range("A1:C" & k).Value = newData2
End Sub

这段代码将会把“Sheet1”中的数据根据第一列的值拆分到两个新的表格中。如果第一列的值是“A”，则数据将被复制到“NewSheet1”中；否则，数据将被复制到“NewSheet2”中。在新的表格中，数据将被复制到A、B、C列中，分别对应原始表格中的A、B、C列。

帮我写一个VBA的代码，要求如下：筛选两个Excel表中的相同数据，并运行到一个新表上

以下是一个简单的 VBA 代码示例，用于将两个 Excel 表中的相同数据筛选出来，并将结果输出到一个新表中：

Sub intersect_tables()
    '定义变量
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim rng1 As Range, rng2 As Range, rng3 As Range
    Dim i As Integer, j As Integer, k As Integer
    
    '先让用户选择要比较的两个表
    Set ws1 = Application.InputBox("请选择第一个表格", Type:=8)
    Set ws2 = Application.InputBox("请选择第二个表格", Type:=8)
    
    '创建新表格
    Set ws3 = Worksheets.Add
    
    '在新表格中创建标题
    ws3.Cells(1, 1) = "相同的数据"
    
    '设置第一个表格中要比较的数据范围
    Set rng1 = ws1.Range("A2:A" & ws1.Cells(Rows.Count, "A").End(xlUp).Row)
    
    '设置第二个表格中要比较的数据范围
    Set rng2 = ws2.Range("A2:A" & ws2.Cells(Rows.Count, "A").End(xlUp).Row)
    
    '遍历第一个表格中的每个数据
    For i = 1 To rng1.Rows.Count
        '遍历第二个表格中的每个数据
        For j = 1 To rng2.Rows.Count
            '如果两个数据相同
            If rng1.Cells(i, 1).Value = rng2.Cells(j, 1).Value Then
                '将相同的数据输出到新表格中
                Set rng3 = ws3.Range("A2:A" & ws3.Cells(Rows.Count, "A").End(xlUp).Row + 1)
                rng3.Cells(k, 1).Value = rng1.Cells(i, 1).Value
                k = k + 1
            End If
        Next j
    Next i
    
    '自适应列宽
    ws3.Columns.AutoFit
    
    '提示运行完毕
    MsgBox "运行完毕！"
End Sub

使用方法：

1. 打开一个新的 Excel 工作簿，按下 Alt+F11 进入 VBA 编辑器；

2. 在左侧的项目窗口中，双击“这个工作簿”；

3. 将以上代码复制到代码窗口中；

4. 按下 F5 运行代码；

5. 依次选择要比较的两个表格，程序将自动筛选出相同的数据，并将结果输出到一个新表格中。