两个excel表,结构相同,请问怎么用VB比较两个表的内容是否一致,并自动生成第三张表返回相同或不相同表1A列B列aaabbbccc表2A列B列abbbbbdcc自动生成表3A列B列相同不相同相同相同不相同相

Question

两个excel表,结构相同,请问怎么用VB比较两个表的内容是否一致,并自动生成第三张表返回相同或不相同
表1
A列 B列
a aa
b bb
c cc
表2
A列 B列
a bb
b bb
d cc
自动生成表3
A列 B列
相同 不相同
相同 相同
不相同 相同

Answer 1

纯手写的测试OK了
有点小辛苦望采纳
我用的VB6.0
新建工程-引用-Microsoft Excel 11.0 Object Library或其它版本
添加一个按钮-双击按钮粘贴下面代码
Dim Xls As New Excel.Application '定义excel应用程序
Dim Xlsbook As Excel.Workbook '定义工作簿
Dim Xlssheet(3) As Excel.Worksheet '定义工作表
Xls.Visible = True '显示excel 程序
Xls.SheetsInNewWorkbook = 1
Set Xlsbook = Xls.Application.Workbooks.Open("C:\Documents and Settings\Administrator\桌面\Book1.xls") '这里改成自己的xls路经
Set Xlssheet(1) = Xlsbook.Sheets(1) '第1个工作表的控制句柄
Set Xlssheet(2) = Xlsbook.Sheets(2)
If Xlsbook.Sheets.Count < 3 Then
Xlsbook.Sheets(1).Select
Xlsbook.Sheets.Add
Xlsbook.Sheets(1).Move After:=Xlsbook.Sheets(Xlsbook.Sheets.Count)
End If
Set Xlssheet(3) = Xlsbook.Sheets(Xlsbook.Sheets.Count)
Dim pd As String,i As Long,j As Long
pd = Xlssheet(1).Range("A1").FormulaR1C1
i = 65
j = 1
Do While pd & "" ""
pd = Xlssheet(1).Range(Chr(i) & j).FormulaR1C1
Do While pd & "" ""
If Xlssheet(1).Range(Chr(i) & j).FormulaR1C1 = Xlssheet(2).Range(Chr(i) & j).FormulaR1C1 Then
Xlssheet(3).Range(Chr(i) & j).FormulaR1C1 = "相同"
Else
Xlssheet(3).Range(Chr(i) & j).FormulaR1C1 = "不相同"
End If
i = i + 1
pd = Xlssheet(1).Range(Chr(i) & j).FormulaR1C1
Loop
i = 65
j = j + 1
pd = Xlssheet(1).Range(Chr(i) & j).FormulaR1C1
DoEvents
Loop
On Error GoTo CheckError
'Xls.DisplayAlerts = False
'Set Xlssheet = Nothing '释放资源
'Xlsbook.Saved = True
'Xlsbook.Close False
'Set Xlsbook = Nothing '释放资源
'Xls.Quit '退出excel应用程序
'Set Xls = Nothing
CheckError:
''''''''''''''''''''''''''''''''''''''''''''''''''
拖拽版.
新建工程-引用-Microsoft Excel 11.0 Object Library或其它版本
直接粘贴下面代码运行后将Excel拖到VB程序的界面上就出结果了
Private Sub Form_Load()
Me.OLEDropMode = 1
End Sub
Function GetTargetPath(ByVal LinkName As String)
On Local Error Resume Next
Dim Obj As Object
Set Obj = CreateObject("Wscript.Shell")
Dim Shortcut As Object
Set Shortcut = Obj.CreateShortcut(LinkName)
GetTargetPath = Shortcut.TargetPath
Shortcut.Save
End Function
Private Sub Form_OLEDragDrop(Data As DataObject,Effect As Long,Button As Integer,Shift As Integer,X As Single,Y As Single)
Dim lj As String
On Local Error Resume Next
If Right(Data.Files.Item(1),3) "lnk" And Right(Data.Files.Item(1),3) "xls" Then Exit Sub
lj = Data.Files.Item(1)
If Right(Data.Files.Item(1),3) = "lnk" Then
lj = GetTargetPath(Data.Files.Item(1))
End If
If Right(lj,3) = "xls" Then
Dim Xls As New Excel.Application '定义excel应用程序
Dim Xlsbook As Excel.Workbook '定义工作簿
Dim Xlssheet(3) As Excel.Worksheet '定义工作表
Xls.Visible = True '显示excel 程序
Xls.SheetsInNewWorkbook = 1
Set Xlsbook = Xls.Application.Workbooks.Open(lj)
Set Xlssheet(1) = Xlsbook.Sheets(1) '第1个工作表的控制句柄
Set Xlssheet(2) = Xlsbook.Sheets(2)
If Xlsbook.Sheets.Count < 3 Then
Xlsbook.Sheets(1).Select
Xlsbook.Sheets.Add
Xlsbook.Sheets(1).Move After:=Xlsbook.Sheets(Xlsbook.Sheets.Count)
End If
Set Xlssheet(3) = Xlsbook.Sheets(Xlsbook.Sheets.Count)
Dim pd As String,i As Long,j As Long
pd = Xlssheet(1).Range("A1").FormulaR1C1
i = 65
j = 1
Do While pd & "" ""
pd = Xlssheet(1).Range(Chr(i) & j).FormulaR1C1
Do While pd & "" ""
If Xlssheet(1).Range(Chr(i) & j).FormulaR1C1 = Xlssheet(2).Range(Chr(i) & j).FormulaR1C1 Then
Xlssheet(3).Range(Chr(i) & j).FormulaR1C1 = "相同"
Else
Xlssheet(3).Range(Chr(i) & j).FormulaR1C1 = "不相同"
End If
i = i + 1
pd = Xlssheet(1).Range(Chr(i) & j).FormulaR1C1
Loop
i = 65
j = j + 1
pd = Xlssheet(1).Range(Chr(i) & j).FormulaR1C1
DoEvents
Loop
End If
End Sub