急！！！求按里面要用两个EXCEL相互比较后生成EXCEL的的例子。（分不够我可以另开）

Question

一个EXCEL有好几个sheet，每个sheet里都有好多字段，但是每个sheet里都会有一个字段为合同号的位置。这个位置和EXCEL都是需要用户自己来添加和上传（选择）的。每次上传两个EXCEL，格式不一定一样，但是都会有一个字段跟合同有关的。用这个合同的这个字段来比较这两个EXCEL，要求输出，这两个表中有相同的合同号的EXCEL记录，其中输出的这个EXCEL中一定包含第一个EXCEL和第二个EXCEL中所有字段及都有这个合同号的记录（这是一个EXCEL）。输出第一个EXCEL中在第二个EXCEL中没有的记录（这是第二张EXCEL），输出第二个EXCEL中第一个EXCEL中没有的记录（这是第三个EXCEL）。一共要输出这三个EXCEL。注（第二个EXCEL的格式和第一个EXCEL格式有两种情况，1种：两个格式一样，第二种不一样，但是都有合同号这个字段，但是这两个合同号里其中一个有合同号字段里的值有一个a，比如其中一个EXCEL的合同字段为：a1000203 而另一个EXCEL的合同字段为： 1000203）
PS：EXCEL可以自己建，两个EXCEL都要有一个可以相互比较的字段谁能给提供个例子，先谢谢大家！

Answer 1

　　VB是常用的应用软件开发工具之一，由于VB的报表功能有限，而且一但报表格式发生变化，就得相应修改程序，给应用软件的维护工作带来极大的不便。因此有很多程序员现在已经充分利用EXCEL的强大报表功来实现报表功能。但由于VB与EXCEL由于分别属于不同的应用系统，如何把它们有机地结合在一起，是一个值得我们研究的课题。　　一、 VB读写EXCEL表：　　VB本身提自动化功能可以读写EXCEL表，其方法如下：　　1、在工程中引用Microsoft Excel类型库：　　从"工程"菜单中选择"引用"栏；选择Microsoft Excel 9.0 Object Library（EXCEL2000），然后选择"确定"。表示在工程中要引用EXCEL类型库。　　2、在通用对象的声明过程中定义EXCEL对象：Dim xlApp As Excel.Application
Dim xlBook As Excel.WorkBook
Dim xlSheet As Excel.Worksheet 　　3、在程序中操作EXCEL表常用命令：Set xlApp = CreateObject("Excel.Application") '创建EXCEL对象
Set xlBook = xlApp.Workbooks.Open("文件名") '打开已经存在的EXCEL工件簿文件
xlApp.Visible = True '设置EXCEL对象可见（或不可见）
Set xlSheet = xlBook.Worksheets("表名") '设置活动工作表
xlSheet.Cells(row, col) =值 '给单元格（row,col）赋值
xlSheet.PrintOut '打印工作表
xlBook.Close (True) '关闭工作簿
xlApp.Quit '结束EXCEL对象
Set xlApp = Nothing '释放xlApp对象
xlBook.RunAutoMacros (xlAutoOpen) '运行EXCEL启动宏
xlBook.RunAutoMacros (xlAutoClose) '运行EXCEL关闭宏 　　4、在运用以上VB命令操作EXCEL表时，除非设置EXCEL对象不可见，否则VB程序可继续执行其它操作，也能够关闭EXCEL，同时也可对EXCEL进行操作。但在EXCEL操作过程中关闭EXCEL对象时，VB程序无法知道，如果此时使用EXCEL对象，则VB程序会产生自动化错误。形成VB程序无法完全控制EXCEL的状况，使得VB与EXCEL脱节。　　二、 EXCEL的宏功能：　　EXCEL提供一个Visual Basic编辑器，打开Visual Basic编辑器，其中有一工程属性窗口，点击右键菜单的"插入模块"，则增加一个"模块1"，在此模块中可以运用Visual Basic语言编写函数和过程并称之为宏。其中，EXCEL有两个自动宏：一个是启动宏（Sub Auto_Open()），另一个是关闭宏（Sub Auto_Close()）。它们的特性是：当用EXCEL打含有启动宏的工簿时，就会自动运行启动宏，同理，当关闭含有关闭宏的工作簿时就会自动运行关闭宏。但是通过VB的自动化功能来调用EXCEL工作表时，启动宏和关闭宏不会自动运行，而需要在VB中通过命令xlBook.RunAutoMacros (xlAutoOpen)和xlBook.RunAutoMacros (xlAutoClose) 来运行启动宏和关闭宏。　　三、 VB与EXCEL的相互勾通：　　充分利用EXCEL的启动宏和关闭宏，可以实现VB与EXCEL的相互勾通，其方法如下：　　在EXCEL的启动宏中加入一段程序，其功能是在磁盘中写入一个标志文件，同时在关闭宏中加入一段删除此标志文件的程序。VB程序在执行时通过判断此标志文件存在与否来判断EXCEL是否打开，如果此标志文件存在，表明EXCEL对象正在运行，应该禁止其它程序的运行。如果此标志文件不存在，表明EXCEL对象已被用户关闭，此时如果要使用EXCEL对象运行，必须重新创建EXCEL对象。　　四、举例：　　1、在VB中，建立一个FORM，在其上放置两个命令按钮，将Ｃommand1的Caption属性改为EXCEL，Command2的Caption属性改为End。然后在其中输入如下程序：Dim xlApp As Excel.Application '定义EXCEL类
Dim xlBook As Excel.Workbook '定义工件簿类
Dim xlsheet As Excel.Worksheet '定义工作表类 
Private Sub Command1_Click() '打开EXCEL过程
　If Dir("D:\temp\excel.bz") = "" Then '判断EXCEL是否打开
　　Set xlApp = CreateObject("Excel.Application") '创建EXCEL应用类
　　xlApp.Visible = True '设置EXCEL可见
　　Set xlBook = xlApp.Workbooks.Open("D:\temp\bb.xls") '打开EXCEL工作簿
　　Set xlsheet = xlBook.Worksheets(1) '打开EXCEL工作表
　　xlsheet.Activate '激活工作表
　　xlsheet.Cells(1, 1) = "abc" '给单元格1行驶列赋值
　　xlBook.RunAutoMacros (xlAutoOpen) 运行EXCEL中的启动宏
　Else
　　MsgBox ("EXCEL已打开")
　End If
End SubPrivate Sub Command2_Click()
　If Dir("D:\temp\excel.bz") <> "" Then '由VB关闭EXCEL
　　xlBook.RunAutoMacros (xlAutoClose) '执行EXCEL关闭宏
　　xlBook.Close (True) '关闭EXCEL工作簿　
　　xlApp.Quit '关闭EXCEL
　End If
　Set xlApp = Nothing '释放EXCEL对象
　End
End Sub
 　　2、在Ｄ盘根目录上建立一个名为Temp的子目录，在Temp目录下建立一个名为"bb.xls"的EXCEL文件。　　3、在"bb.xls"中打开Visual Basic编辑器，在工程窗口中点鼠标键选择插入模块，在模块中输入入下程序存盘：
Sub auto_open()
　Open "d:\temp\excel.bz" For Output As #1 '写标志文件
　Close #1
End Sub
Sub auto_close()
　Kill "d:\temp\excel.bz" '删除标志文件
End Sub 　　4、运行VB程序，点击EXCEL按钮可以打开EXCEL系统，打开EXCEL系统后，VB程序和EXCEL分别属两个不同的应用系统，均可同时进行操作，由于系统加了判断，因此在VB程序中重复点击EXCEL按钮时会提示EXCEL已打开。如果在EXCEL中关闭EXCEL后再点EXCEL按钮，则会重新打开EXCEL。而无论EXCEL打开与否，通过VB程序均可关闭EXCEL。这样就实现了VB与EXCEL的无缝连接。 

Answer 2

'检测文件
Function CheckFile(ByVal strFile As String) As Boolean
Dim FileXls As Object
Set FileXls = CreateObject("Scripting.FileSystemObject")    If IsNull(strFile) Or strFile = "" Then
    CheckFile = False
    
    Exit Function
    End If
    If FileXls.FileExists(strFile) = False Then
       
        CheckFile = False
        Set FileXls = Nothing
        Exit Function
    Else
        
        CheckFile = True
        Set FileXls = Nothing
    End If
    
    
End Function
'检测工作表
Function CheckSheet(ByVal strSheet As String, ByVal strWorkBook As String, xlCheckApp As Excel.Application) As Boolean
Dim L As Integer
Dim CheckWorkBook As Excel.WorkbookIf CheckFile(strWorkBook) And strSheet <> "" And Not IsNull(strSheet) Then
    For L = 1 To xlCheckApp.Workbooks.Count
    If GetPath(xlCheckApp.Workbooks(L).Path) & xlCheckApp.Workbooks(L).Name = strWorkBook Then
    Set CheckWorkBook = xlCheckApp.Workbooks(L)
    Exit For
    End If
    Next L
    
    
    
    Set CheckWorkBook = xlCheckApp.Workbooks.Open(strWorkBook)
    For L = 1 To CheckWorkBook.Worksheets.Count
        If CheckWorkBook.Worksheets(L).Name = Trim(strSheet) Then
            CheckSheet = True
            Exit For
        End If
    Next LElse
    MsgBox "工作表不存在，可能是由文件名或工作表名引起的！"
    CheckSheet = False
End IfEnd Function'建立工作表
'CreateMethod:1追加
'CreateMethod:2覆盖
Function CreateSheet(ByVal strSheetName As String, ByVal strWorkBook As String, ByVal CreateMethod As Integer, xlCreateApp As Excel.Application) As Boolean
Dim xlCreateSheet As Excel.Worksheet    
    If CheckFile(strWorkBook) Then
    
        xlCreateApp.Workbooks.Open (strWorkBook)
        
        
        If CreateMethod = 1 Then
        
        If CheckSheet(strSheetName, strWorkBook, xlCreateApp) = False Then
        
        Set xlCreateSheet = xlCreateApp.Worksheets.Add
        xlCreateSheet.Name = strSheetName
        xlCreateApp.ActiveWorkbook.Save
        
        CreateSheet = True
        Set xlCreateSheet = Nothing
        Else
        'MsgBox strSheetName & "工作表已存在！"
        CreateSheet = False
        Set xlCreateSheet = Nothing
        End If
        
        
        ElseIf CreateMethod = 2 Then
        If CheckSheet(strSheetName, strWorkBook, xlCreateApp) = True Then
        Set xlCreateSheet = xlCreateApp.Worksheets(strSheetName)
        xlCreateSheet.Cells.Select
        xlCreateSheet.Cells.Delete
        xlCreateApp.ActiveWorkbook.Save
        CreateSheet = True
        Set xlCreateSheet = Nothing
        Else
        'MsgBox strSheetName & "工作表不存在！"
        CreateSheet = False
        Set xlCreateSheet = Nothing
        End If
        
        End If
        
    End If
    End Function
'删除工作表
Function DeleteSheet(ByVal strSheetName As String, ByVal strWorkBook As String, xlDeleteApp As Excel.Application) As Boolean
Dim i As Integer
Dim xlDeleteSheet As Excel.Worksheet
    
    If CheckFile(strWorkBook) Then
    
    If CheckSheet(strSheetName, strWorkBook, xlDeleteApp) = True Then
    
    xlDeleteApp.Workbooks.Open (strWorkBook)
    
    If xlDeleteApp.Worksheets.Count = 1 Then
        MsgBox "工作薄不能全部删除，" & strSheetName & "是最后一个工作表！"
        DeleteSheet = False
        Exit Function
    End If
    
    xlDeleteApp.Worksheets(strSheetName).Delete    xlDeleteApp.ActiveWorkbook.Save
    DeleteSheet = True
    Else
    DeleteSheet = False
    End If
    
    End If
    
End Function'复制工作表
Function CopySheet(ByVal strSrcSheetName As String, ByVal strSrcWorkBook As String, ByVal strTagSheetName As String, ByVal strTagWorkbook As String, xlCopyApp As Excel.Application) As Boolean
Dim xlSrcBook As Excel.Workbook
Dim xlTagBook As Excel.Workbook
Dim ExcelSource As Excel.Worksheet
Dim ExcelTarget As Excel.Worksheet
Dim Result As BooleanIf CheckFile(strSrcWorkBook) = False Or CheckFile(strTagWorkbook) = False Then
Set ExcelSource = Nothing
Set ExcelTarget = Nothing
Set xlSrcBook = Nothing
Set xlTagBook = Nothing
    CopySheet = False
    Exit Function
Else

Answer 3

Set xlSrcBook = xlCopyApp.Workbooks.Open(strSrcWorkBook)
    
    If strSrcWorkBook = strTagWorkbook Then
        If strSrcSheetName = strTagSheetName Then
        Set ExcelSource = Nothing
        Set ExcelTarget = Nothing
        Set xlSrcBook = Nothing
        Set xlTagBook = Nothing
        CopySheet = False
        Exit Function
        End If
    
        Set xlTagBook = xlSrcBook
    Else
    Set xlTagBook = xlCopyApp.Workbooks.Open(strTagWorkbook)
    End If
    
    
    
    Set ExcelSource = xlSrcBook.Worksheets(strSrcSheetName)
    Set ExcelTarget = xlTagBook.Worksheets(strTagSheetName)    ExcelSource.Select
    ExcelSource.Cells.Copy
    ExcelTarget.Select
    ExcelTarget.Paste
    xlCopyApp.Application.CutCopyMode = xlCopy
    
    If strSrcWorkBook = strTagWorkbook Then
    xlTagBook.Save
    xlSrcBook.Save
    Else
    xlTagBook.Save
    End If
    
Set ExcelSource = Nothing
Set ExcelTarget = Nothing
Set xlSrcBook = Nothing
Set xlTagBook = Nothing
    CopySheet = True
End If
End Function
'复制工作表
Function ExcelCopySheet(ByVal strSrcSheetName As String, ByVal strSrcWorkBook As String, ByVal strTagSheetName As String, ByVal strTagWorkbook As String, xlCopyApp As Excel.Application) As Boolean
Dim xlSrcBook As Excel.Workbook
Dim xlTagBook As Excel.Workbook
Dim ExcelSource As Excel.Worksheet
Dim ExcelTarget As Excel.Worksheet
Dim Result As BooleanIf CheckFile(strSrcWorkBook) = False Or CheckFile(strTagWorkbook) = False Then
Set ExcelSource = Nothing
Set ExcelTarget = Nothing
Set xlSrcBook = Nothing
Set xlTagBook = Nothing
    CopySheet = False
    Exit Function
Else    Set xlSrcBook = xlCopyApp.Workbooks.Open(strSrcWorkBook)
    
    If strSrcWorkBook = strTagWorkbook Then
        If strSrcSheetName = strTagSheetName Then
        Set ExcelSource = Nothing
        Set ExcelTarget = Nothing
        Set xlSrcBook = Nothing
        Set xlTagBook = Nothing
        CopySheet = False
        Exit Function
        End If
    
        Set xlTagBook = xlSrcBook
    Else
    Set xlTagBook = xlCopyApp.Workbooks.Open(strTagWorkbook)
    End If
    
    
    
    Set ExcelSource = xlSrcBook.Worksheets(strSrcSheetName)
    Set ExcelTarget = xlTagBook.Worksheets(strTagSheetName)    ExcelSource.Select
    ExcelSource.Copy before
    ExcelTarget.Select
    ExcelTarget.Paste
    xlCopyApp.Application.CutCopyMode = xlCopy
    
    If strSrcWorkBook = strTagWorkbook Then
    xlTagBook.Save
    xlSrcBook.Save
    Else
    xlTagBook.Save
    End If
    
Set ExcelSource = Nothing
Set ExcelTarget = Nothing
Set xlSrcBook = Nothing
Set xlTagBook = Nothing
    CopySheet = True
End If
End Function'关闭Excel应用
Function CloseExcelApp(xlApp As Object)
On Error Resume Next
xlApp.Quit
Set xlApp = Nothing
End Function'建立Excel应用
Function CreateExcelApp(QuitApp As Boolean) As Object
On Error Resume Next
Dim xlObject As Object
If CheckExcel ThenSet xlObject = GetObject(, "Excel.Application")
If err.Number <> 0 Then
    Set xlObject = Nothing
    Set xlObject = CreateObject("Excel.Application")
    CreateExcelApp = xlObject
Else
    If QuitApp Then
    xlObject.Quit
    Set xlObject = Nothing
    Set xlObject = CreateObject("Excel.Application")
    End If
    CreateExcelApp = xlObject
End IfEnd IfEnd Function'检测EXCEL环境
Function CheckExcel() As Boolean
Dim xlCheckApp As Object
Set xlCheckApp = CreateObject("Excel.Application")    If xlCheckApp Is Nothing Then
        MsgBox "对不起，系统未检测到EXCEL安装，请重新检查EXCEL是否被正确安装！"
        CheckExcel = False
        xlCheckApp.Quit
        Set xlCheckApp = Nothing
        Exit Function
    Else
        xlCheckApp.Quit
        CheckExcel = True
        Set xlCheckApp = Nothing
    End If
End FunctionFunction CreateWorkBook(ByVal strWorkBook As String, xlApp As Excel.Application)
Dim xlCreateWorkBook As Excel.WorkbookSet xlCreateWorkBook = xlApp.Workbooks.AddxlCreateWorkBook.SaveAs (strWorkBook)
End Function
Function GetPath(strPath As String) As String
GetPath = IIf(Len(strPath) = 3, strPath, strPath & "\")
End Function

Answer 4

Sub example()
  Set VBExcel1 = CreateObject("excel.application")
  Set xBook1 = VBExcel.Workbooks.open("E:\11.xls")
  Set xSheet1 = xBook.Worksheets("sheet1") '打开第一个EXCEL
  Set VBExcel2 = CreateObject("excel.application")
  Set xBook2 = VBExcel.Workbooks.open("E:\12.xls")
  Set xSheet2 = xBook.Worksheets("sheet1") '打开第二个EXCEL
  Set vbe = CreateObject("excel.application")
  Set xb = vbe.Workbooks.Add
  Set xs = xb.Worksheets(1)'创建一个新的EXCEL
  '用FOR 循环对EXCEL里的内容遍历比较后,把生成结果存在新建的EXCEL里
    k=0
    For j = 3 To 500
                If xSheet1.Cells(j, 1) = xSheet2.Cells(j, 1) Then
                    k = k + 1
                     xs.Cells(k + 1, 2) = xSheet.Cells(j, 2)
                End If
    Next j
xb.SaveAs "E:\13.xls"
xb.Close
vbe.Quit
xBook1.Close
VBExcel1.Quit
xBook2.Close
VBExcel2.Quit
End Sub