按条件查找不重复数据

宝玉66

老师，由于数据太多有2万多行，想求一个按条件查找不重复数据的代码，请帮忙。

liulang0808

建议楼主结合附件，描述下具体需求
目前看不明白具体做什么及怎么做

宝玉66

老师，附件已把需求标注好了，请帮忙看一下。

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i As Long, j As Long, s As String, n As Long
  arr = [a3].CurrentRegion
  s = [j6].Value: n = 1
  For i = 2 To UBound(arr, 1)
    If arr(i, 2) = s Then
      n = n + 1
      For j = 1 To UBound(arr, 2): arr(n, j) = arr(i, j): Next
    End If
  Next
  With [h9]
    .Resize(Rows.Count - 9, UBound(arr, 2)).ClearContents
    .Resize(n, UBound(arr, 2)) = arr
  End With
End Sub

宝玉66

一把小刀闯天下 发表于 2018-7-11 13:37
Option Explicit

Sub test()

老师，在麻烦您一下，您写的代码运用到别的表上数据出错了，能帮忙在看一下吗，谢谢。

opaiii

Sub Screen()
    Dim Cnn As Object, SQL As String, sPath As String
    Set Cnn = CreateObject("adodb.connection")
    sPath = ThisWorkbook.FullName
    If Val(Application.Version) < 12 Then
        Cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;Hdr=yes';data source=" & sPath
    Else
        Cnn.Open "provider=microsoft.ACE.oledb.12.0;extended properties='excel 12.0;Hdr=yes';data source=" & sPath
    End If
    SQL="select A from [Sheet1$] group by B"
    'A就写你要选的东西，B就是你要根据的条件筛选
    Set Rst = Cnn.Execute(SQL1)
    With Sheets(2)
        If Not IsEmpty(.UsedRange) Then .UsedRange.Clear
        .[a1:b1] = ["自己填","表头"]
        .[a2].CopyFromRecordset Rst
    End With
    Cnn.Close
    Set Cnn = Nothing
End Sub

没看你的表，你可以自己看一下，主要就是那个SQL语句，group by就是根据你选择的那一列进行分类

lsc900707

宝玉66 发表于 2018-7-11 17:27
老师，在麻烦您一下，您写的代码运用到别的表上数据出错了，能帮忙在看一下吗，谢谢。

1. Sub gj23w98()
   
2.     arr = [a1].CurrentRegion
   
3.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
4.     For i = 2 To UBound(arr)
   
5.         If arr(i, 5) = [i1] Then
   
6.             m = m + 1
   
7.             For j = 1 To UBound(arr, 2)
   
8.                 brr(m, j) = arr(i, j)
   
9.             Next
   
10.         End If
    
11.     Next
    
12.     If m Then
    
13.         [h9].CurrentRegion.Offset(1).ClearContents
    
14.         [h10].Resize(m, UBound(brr, 2)) = brr
    
15.     End If
    
16. End Sub

复制代码

jjmysjg

lsc900707 发表于 2018-7-11 18:15

OK谢谢版主

lsc900707

宝玉66 发表于 2018-7-11 17:27
老师，在麻烦您一下，您写的代码运用到别的表上数据出错了，能帮忙在看一下吗，谢谢。

参考附件：

一把小刀闯天下

宝玉66 发表于 2018-7-11 17:27
老师，在麻烦您一下，您写的代码运用到别的表上数据出错了，能帮忙在看一下吗，谢谢。

'源数据表改变了，条件位置也改变了。稍作修改再试一下

Option Explicit

Sub test()
   Dim arr, i As Long, j As Long, s As String, n As Long
   arr = [a1].CurrentRegion
   s = [i1].Value: n = 1
   For i = 2 To UBound(arr, 1)
     If arr(i, 5) = s Then
       n = n + 1
       For j = 1 To UBound(arr, 2): arr(n, j) = arr(i, j): Next
     End If
   Next
   With [h9]
     .Resize(Rows.Count - 8, UBound(arr, 2)).ClearContents
     .Resize(n, UBound(arr, 2)) = arr
   End With
End Sub