对比差异差异（数据量超过1百万行）

tanglf188

lg747699

shiruiqiang 发表于 2024-7-2 08:54
根据表，汇总成2个数组。
再把1个数组遍历成字典，值为数组名。对另一数组判断exists，2者是否同时存在

再把1个数组遍历成字典，值为数组名。对另一数组判断exists，2者是否同时存在

把不存在的差异提取出来。

魂断蓝桥

Option Explicit
Sub a()
    Dim cat, strconn As String, tb1, tb2
    Dim myf As String
    Application.ScreenUpdating = False
    myf = ThisWorkbook.Path & "\a.mdb"
    If Dir(myf) <> "" Then Kill myf
    Set cat = CreateObject("adox.catalog")
    strconn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & myf
    cat.Create strconn
    Set tb1 = CreateObject("ADOX.Table")
    Set tb2 = CreateObject("ADOX.Table")
    With tb1
        .ParentCatalog = cat
        .Name = "T1"
        .Columns.Append "ID", 3
        .Columns("ID").Properties("AutoIncrement") = True
        .Columns.Append "编号", 202, 50
        .Keys.Append "PrimaryKey", 1, "ID"
        cat.Tables.Append tb1
    End With
    With tb2
        .ParentCatalog = cat
        .Name = "T2"
        .Columns.Append "ID", 3
        .Columns("ID").Properties("AutoIncrement") = True
        .Columns.Append "编号", 202, 50
        .Keys.Append "PrimaryKey", 1, "ID"
        cat.Tables.Append tb2
    End With
    Set cat.ActiveConnection = Nothing
    Dim myfile As String, wb As Workbook, i&, J&, m&, arr, cnn, sql$
    myf = ThisWorkbook.Path & "\"
    myfile = Dir(myf & "*订单*.xls*")
    Set cnn = CreateObject("ADODB.CONNECTION")
    cnn.Open "Provider=Microsoft.jet.OLEDB.4.0;" & "Data Source=" & ThisWorkbook.Path & "\a.mdb"
    Do While myfile <> ""
        If myfile <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & myfile)
            If wb.Sheets.Count > 1 Then
                For i = 1 To wb.Sheets.Count
                    arr = wb.Sheets(i).[A1].CurrentRegion
                    For J = 1 To 5 Step 4
                        For m = 1 To UBound(arr)
                            sql = "INSERT INTO T2(编号) VALUES('" & arr(m, J) & "')"
                            cnn.Execute sql
                        Next
                    Next
                Next
            Else
                arr = wb.Sheets(1).[A1].CurrentRegion
                For m = 2 To UBound(arr)
                    sql = "INSERT INTO T1(编号) VALUES('" & arr(m, 1) & "')"
                    cnn.Execute sql
                Next
            End If
            wb.Close 0
        End If
        myfile = Dir
    Loop
    With Sheet2
        .Cells.Clear
        .[A1] = "ERP有但SRM找不到"
        .[D1] = "SRM有但ERP查不到"
        sql = "select 编号 FROM T1 WHERE 编号 NOT IN (SELECT 编号 from T2)"
        .Range("B2").CopyFromRecordset cnn.Execute(sql)
        sql = "select 编号 FROM T2 WHERE 编号 NOT IN (SELECT 编号 from T1)"
        .Range("E2").CopyFromRecordset cnn.Execute(sql)
    End With
    Set cnn = Nothing
     Application.ScreenUpdating = True
End Sub

lg747699

魂断蓝桥 发表于 2024-7-2 09:07
Option Explicit
Sub a()
    Dim cat, strconn As String, tb1, tb2

老师，为什么显示我“部件没有注册”

limonet

关键字：schema(20)

limonet

Sub limonet()
    Dim Cn As Object, SQLERP$, SQLSRM$, Sht
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;hdr=no';Data Source=" & ThisWorkbook.Path & "\srm订单.xls"
    SQLERP = "Select F1 as ERP From [Excel 12.0;hdr=no;Database=" & ThisWorkbook.Path & "\erp订单1.xlsx" & "].[sheet1$A2:A] Union All " _
            & "Select F1 as ERP From [Excel 12.0;hdr=no;Database=" & ThisWorkbook.Path & "\erp订单2.xlsx" & "].[sheet1$A2:A]"
    For Each Sht In Cn.openschema(20).GetRows(, , "TABLE_NAME")
        SQLSRM = SQLSRM & " Union All Select F1 as SRM From [" & Replace(Sht, "'", "") & "] Union All Select F5 From [" & Replace(Sht, "'", "") & "]"
    Next Sht
    StrSQL = "Select b.* From (" & SQLERP & ")a Right Join (" & Mid(SQLSRM, 12) & ")b On a.ERP=b.SRM Where a.erp is NUll" 'OK
    Range("B2").CopyFromRecordset Cn.Execute(StrSQL)
    StrSQL = "Select a.* From (" & SQLERP & ")a Left Join (" & Mid(SQLSRM, 12) & ")b On a.ERP=b.SRM Where b.srm is NUll" 'OK
    Range("A2").CopyFromRecordset Cn.Execute(StrSQL)
End Sub

魂断蓝桥

lg747699 发表于 2024-7-2 09:30
老师，为什么显示我“部件没有注册”

没有ado控件，需要安装access，如果数据量不大，就不需要access

lg747699

limonet 发表于 2024-7-2 09:47
Sub limonet()
    Dim Cn As Object, SQLERP$, SQLSRM$, Sht
    Set Cn = CreateObject("Adodb.Connect ...

刚刚试了，数据太大，失败了

魂断蓝桥

lg747699 发表于 2024-7-2 10:23
刚刚试了，数据太大，失败了

超过100万的话，用sqlite更好一些，你得excel是32位还是64位，如果32位可用vbRichClient5

lg747699

limonet 发表于 2024-7-2 09:47
Sub limonet()
    Dim Cn As Object, SQLERP$, SQLSRM$, Sht
    Set Cn = CreateObject("Adodb.Connect ...