用VBA查找和删除Word中多个表格

用VBA查找和删除Word中多个#格# 有时要操作、编辑较多的表格的word文件，因数量较多而非常困难，象我公司今年有合理化建议表670份，我把它集中在一个word文件内，但要进行分类评审、查找、修改、检索、相同的表格删除非常不方便，为此我研究了一天，找到了用VBA查找和删除Word中多个表格的方法，今分享如下： 1、删除文件中不要的表格 评审后新的合理化项目表名为："生产配料成本测算控制方法 降低原料消耗 减少破坏威胁程度 合理利用废旧除尘布袋 大面下料管改造 炉壳喷淋水冷……粘结剂改进"。 把不在里面名称的表格删除 Public Sub del() Dim s As String, t As String, u As String, v As String Dim i As Integer, j As Integer, k As Integer, l As Integer, p As Integer, q As Integer, r As Integer Dim a() As String s = "生产配料成本测算控制方法 降低原料消耗 减少破坏威胁程度 合理利用废旧除尘布袋 大面下料管改造 炉壳喷淋水冷……粘结剂改进" //不够可用几个String变量，合并变量即可 a = Split(s) k = UBound(a) While p = 0 ff: For i = 1 To 10000 t = Trim(ActiveDocument.Tables(i).Cell(1, 2).Range) //假设名称在表格第一行第二列 u = Mid(t, 1, Len(t) - 2) t = Trim(u) r = 0 For j = 0 To k If t = Trim(a(j)) Then r = 1 Next If r = 0 Then ActiveDocument.Tables(i).Delete GoTo ff End If Next Wend End Sub 2、查找重复的表格 Public Sub zhao() Dim s As String, t As String, u As String, v As String Dim i As Integer, j As Integer, k As Integer, l As Integer, p As Integer, q As Integer, r As Integer Dim a() As String, b() As Integer s ="生产配料成本测算控制方法 降低原料消耗 减少破坏威胁程度 合理利用废旧除尘布袋 大面下料管改造 炉壳喷淋水冷……粘结剂改进" //不够可用几个String变量，合并变量即可 a = Split(s) k = UBound(a) ReDim b(k + 2) For i = 0 To k b(i) = 0 Next r = 572 //输入表格个数 For i = 1 To r t = Trim(ActiveDocument.Tables(i).Cell(1, 2).Range) //假设名称在表格第一行第二列 u = Mid(t, 1, Len(t) - 2) t = Trim(u) For j = 0 To k If t = Trim(a(j)) Then b(j) = b(j) + 1 End If Next Next For i = 0 To k If b(i) > 1 Then MsgBox (a(i)) Next End Sub 3、查找缺失的表格 Public Sub zhao2() Dim s As String, t As String, u As String, v As String Dim i As Integer, j As Integer, k As Integer, l As Integer, p As Integer, q As Integer, r As Integer Dim a() As String, b() As Integer s = "生产配料成本测算控制方法 降低原料消耗 减少破坏威胁程度 合理利用废旧除尘布袋 大面下料管改造 炉壳喷淋水冷……粘结剂改进" //不够可用几个String变量，合并变量即可 a = Split(s) k = UBound(a) ReDim b(k + 2) For i = 0 To k b(i) = 0 Next r = 619 //输入表格个数 For i = 1 To r t = Trim(ActiveDocument.Tables(i).Cell(1, 2).Range) //假设名称在表格第一行第二列 u = Mid(t, 1, Len(t) - 2) t = Trim(u) For j = 0 To k If t = Trim(a(j)) Then b(j) = b(j) + 1 End If Next Next For i = 0 To k If b(i) < 1 Then MsgBox (a(i)) Next End Sub