|
i30jCVg1.rar
(14.07 KB, 下载次数: 18)
多余的话，我不多话了，可以参考我的另一个比较程序中的一些说明。
可以运行 COMPARECELLSFORAMT命令。
注意：电脑与人脑的不同，导致表格比较来得非常麻烦，每个单元格的四个边框线逐一比对，很累，也很耗资源，需要时间，请耐心等待。
有问题，可以再作交流
以下代码供参考：
'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By I Love You_Word!@ExcelHome 2005-4-27 5:44:00
'仅测试于System: Windows NT Word: 10.0 Language: 2052
'^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Option Explicit
Sub CompareCellsFormat()
Dim aCell As Cell, i As Byte, MyDialog As FileDialog, vrtSelectedItem As Variant, aDoc As Document
Dim ErrorText As String, ThatTable As Table, Rid As Integer, Cid As Integer, ThatCell As Cell
On Error Resume Next '忽略错误
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
With MyDialog
.Filters.Clear '清除所有文件筛选器中的项目
.Filters.Add "所有 WORD 文件", "*.doc", 1 '增加筛选器的项目为所有WORD文件
.AllowMultiSelect = True '允许多项选择,可用SHIFT/CTRL进行选定
End With
If MyDialog.Show = -1 Then '确定
For Each vrtSelectedItem In MyDialog.SelectedItems '在所有选取项目中循环
'以隐藏方式打开指定文件夹中的文档
Set aDoc = Documents.Open(FileName:=vrtSelectedItem, Visible:=False)
'判断表格数量,如果不为1个表格,则提示后退出程序
If aDoc.Tables.Count <> 1 Then MsgBox "Word没有找到表格!", vbExclamation: Exit Sub
'定义一个表格对象,为被比较文档的第一个表格
Set ThatTable = aDoc.Tables(1)
ErrorText = "" '初始化变量
With ThisDocument '本文档(正确答案,标准文档)
'比较本文档与被比文档的表格总行数
If .Tables(1).Rows.Count <> ThatTable.Rows.Count Then ErrorText = "表格行数不同" & vbCrLf
'比较本文档与被比文档的表格总列数
If .Tables(1).Columns.Count <> ThatTable.Columns.Count Then ErrorText = "表格宽数不同" & vbCrLf
'比较本文档与被比文档的单元格总数
If .Tables(1).Range.Cells.Count <> ThatTable.Range.Cells.Count Then ErrorText = "表格单元格总数不同" & vbCrLf
'如果出现以上任意三种情况其ERRORTEXT不为空,则提示后退出程序
If ErrorText <> "" Then MsgBox ErrorText, vbExclamation: Exit Sub
'比较表格中的插入域数量是否相同
If .Tables(1).Range.Fields.Count <> ThatTable.Range.Fields.Count Then ErrorText = ErrorText & "表格中插入域数量不同" & vbCrLf
Application.ScreenUpdating = False '关闭屏幕更新
'遍历本文档中的单元格
For Each aCell In ThisDocument.Tables(1).Range.Cells
With aCell
Rid = .RowIndex '取得行号
Cid = .ColumnIndex '取得列号
Set ThatCell = ThatTable.Cell(Rid, Cid) '定义一个相同位置的单元格对象
For i = 1 To 4 '在四条边框线上取得不同的对象属性
If .Borders(-i).LineStyle <> ThatCell.Borders(-i).LineStyle Then ErrorText = ErrorText & "单元格(" & Rid & "," & Cid & ")边框线型不同" & vbCrLf
If .Borders(-i).LineWidth <> ThatCell.Borders(-i).LineWidth Then ErrorText = ErrorText & "单元格(" & Rid & "," & Cid & ")边框线宽不同" & vbCrLf
If .Borders(-i).Color <> ThatCell.Borders(-i).Color Then ErrorText = ErrorText & "单元格(" & Rid & "," & Cid & ")边框线颜色不同" & vbCrLf
Next
'比较两者的文本内容(包括域文本)
If .Range.Text <> ThatCell.Range.Text Then ErrorText = ErrorText & "单元格(" & Rid & "," & Cid & ")文本内容不同" & vbCrLf
'比较两者的段落水平位置
If .Range.ParagraphFormat.Alignment <> ThatCell.Range.Paragraphs.Alignment Then ErrorText = ErrorText & "单元格(" & Rid & "," & Cid & ")段落格式不同" & vbCrLf
'比较两者的段落行间距
If .Range.ParagraphFormat.LineSpacing <> ThatCell.Range.ParagraphFormat.LineSpacing Then ErrorText = ErrorText & "单元格(" & Rid & "," & Cid & ")段落行距不同" & vbCrLf
'比较两者的RANGE格式(字体,颜色,字号等)
If .Range.Duplicate <> ThatCell.Range.Duplicate Then ErrorText = ErrorText & "单元格(" & Rid & "," & Cid & ")文字格式不同" & vbCrLf
'比较两者的底纹
If .Shading.BackgroundPatternColor <> ThatCell.Shading.BackgroundPatternColor Then ErrorText = ErrorText & "单元格(" & Rid & "," & Cid & ")底纹格式不同" & vbCrLf
'比较两者的单元格垂直位置
If .VerticalAlignment <> ThatCell.VerticalAlignment Then ErrorText = ErrorText & "单元格(" & Rid & "," & Cid & ")垂直对齐方式不同" & vbCrLf
End With
Next aCell
End With
aDoc.Content.InsertAfter vbCrLf & ErrorText '插入指定的比较结果
aDoc.Close True '保存并退出
Next vrtSelectedItem
End If
Application.ScreenUpdating = True '恢复屏幕更新
'提示结束
MsgBox "表格比较结束,请您核对!", vbInformation + vbOKOnly
End Sub
'---------------------- | 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2005-4-23 16:14
楼主
