用公式或VB将两个表不重复数据提取到第三个表

程育政

从(上版)和(新版)两个表中把不重复的数据   整行提取到(提取不重复项)的表中

wengjl

以哪列数据作为不重复的标准？

wengjl

以采购订单号为准可以吗？

程育政

是只提取(新版)表中与(上版)不重复的数据提取到(提取不重复项)表中

wengjl

我的办公电脑有加密，所以贴个代码
Sub 提取不重复项()
    '
    ' 问题来源：https://club.excelhome.net/thread-1686963-1-1.html
    '
    ' 需求：从上版和新版二表中提取不重复项到新表上
    '
    ' 时间：2024-3-14
   
    Sheet4.Select
    Rows("2:20000").Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
   
    x2 = 2
    Do While Not (IsEmpty(Sheet2.Cells(x2, 5).Value))
      x4 = 2
      foun = False
      Do While Not (IsEmpty(Sheet4.Cells(x4, 5).Value))
        If Sheet4.Cells(x4, 5).Value = Sheet2.Cells(x2, 5).Value Then
          foun = True
        End If
        x4 = x4 + 1
      Loop
      If foun = False Then
        For y = 1 To 10
          Sheet4.Cells(x4, y).Value = Sheet2.Cells(x2, y).Value
        Next y
      End If
      x2 = x2 + 1
    Loop
    '-----
    x3 = 2
    Do While Not (IsEmpty(Sheet3.Cells(x3, 5).Value))
      x4 = 2
      foun = False
      Do While Not (IsEmpty(Sheet4.Cells(x4, 5).Value))
        If Sheet4.Cells(x4, 5).Value = Sheet3.Cells(x3, 5).Value Then
          foun = True
        End If
        x4 = x4 + 1
      Loop
      If foun = False Then
        For y = 1 To 10
          Sheet4.Cells(x4, y).Value = Sheet3.Cells(x3, y).Value
        Next y
      End If
      x3 = x3 + 2
    Loop
   
End Sub

LIUZHU

不重复的提取的例子太多了，一般就是用字典判断

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, i&, j&, dic As Object, strJoin$, vKey
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    With Sheets(2).[A1].CurrentRegion
        ar = .Value
        For i = 2 To UBound(ar)
            strJoin = ""
            For j = 1 To UBound(ar, 2)
                strJoin = strJoin & "," & CStr(ar(i, j))
            Next j
            dic(strJoin) = .Rows(i)
        Next i
    End With
    With Sheets(3).[A1].CurrentRegion
        ar = .Value
        For i = 2 To UBound(ar)
            strJoin = ""
            For j = 1 To UBound(ar, 2)
                strJoin = strJoin & "," & CStr(ar(i, j))
            Next j
            If dic.exists(strJoin) Then
                dic.Remove strJoin
            Else
                dic(strJoin) = .Rows(i)
            End If
        Next i
    End With
   
    With Sheets(4)
        .[A1].CurrentRegion.Offset(1).ClearContents
        .[A2].Resize(dic.Count, UBound(ar, 2)) = Application.Rept(dic.items, 1)
        .Activate
    End With
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考。。。

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.3.14
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     For Each Sht In Sheets
   
6.         If InStr(Sht.Name, "版") Then
   
7.             With Sht
   
8.                 r = .Cells(.Rows.Count, 5).End(xlUp).Row
   
9.                 arr = .[a1].Resize(r, 9)
   
10.             End With
    
11.             For i = 2 To UBound(arr)
    
12.                 s = arr(i, 5)
    
13.                 d(s) = d(s) + 1
    
14.             Next
    
15.         End If
    
16.     Next
    
17.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
18.     For Each Sht In Sheets
    
19.         If InStr(Sht.Name, "版") Then
    
20.             With Sht
    
21.                 r = .Cells(.Rows.Count, 5).End(xlUp).Row
    
22.                 arr = .[a1].Resize(r, 9)
    
23.             End With
    
24.             For i = 2 To UBound(arr)
    
25.                 s = arr(i, 5)
    
26.                 If d(s) = 1 Then
    
27.                     m = m + 1
    
28.                     For j = 1 To UBound(arr, 2)
    
29.                         brr(m, j) = arr(i, j)
    
30.                     Next
    
31.                 End If
    
32.             Next
    
33.         End If
    
34.     Next
    
35.     With Sheets("提取不重复项")
    
36.         .UsedRange.Offset(1).ClearContents
    
37.         .[a2].Resize(m, UBound(arr, 2)) = brr
    
38.     End With
    
39.     Set d = Nothing
    
40.     Application.ScreenUpdating = True
    
41.     MsgBox "OK！"
    
42. End Sub
    

复制代码