VBA 排序 + 筛选重复字段

skch0210

请教各位大神，

附件中A列（物料号）会有一些重复字段，如何通过VBA选中所有A列中的重复字段，并且把对应的B到H列中的信息也显示出来？

在实现了上述功能之后，请问能不能通过FY17 volume 再对选中的值排出前10名呢？

感谢各位赐教。

skch0210

附件请见下方，谢谢

duquancai

附件呢？           

一把小刀闯天下

Option Explicit

Sub test()
  Dim i, j, k, arr, dic, n, t
  Set dic = CreateObject("scripting.dictionary")
  With Sheets("v")
    arr = .[a1].CurrentRegion
    For i = 2 To UBound(arr, 1): dic(arr(i, 1)) = dic(arr(i, 1)) + 1: Next
    .Cells.Interior.ColorIndex = xlNone
    For i = 1 To UBound(arr, 1)
      If dic(arr(i, 1)) > 1 Then
        n = n + 1
        For j = 1 To UBound(arr, 2): arr(n + 1, j) = arr(i, j): Next
        .Cells(i, 1).Resize(, UBound(arr, 2)).Interior.Color = vbRed
      End If
    Next
  End With
  With Sheets("sheet1")
    For i = 2 To n
      For j = i + 1 To n + 1
        If arr(i, 6) < arr(j, 6) Then
          For k = 1 To UBound(arr, 2)
            t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
          Next
        End If
    Next j, i
    n = IIf(n > 10, 10, n)
    .Cells.ClearContents
    .[a1].Resize(n + 1, UBound(arr, 2)) = arr
  End With
End Sub

duquancai

skch0210 发表于 2018-6-23 21:41
附件请见下方，谢谢

通过VBA筛选所有A列中的重复，通过FY17 volume 再对选中的值排出前10名！！！

1. Sub main()
   
2.     Dim conn As Object, rst As Object, s$, sql$
   
3.     Set conn = CreateObject("adodb.connection")
   
4.     Set rst = CreateObject("ADODB.recordset")
   
5.     conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;extended properties='excel 12.0;hdr=no';data source=" & ThisWorkbook.FullName
   
6.     s = "select f1 from [v$a2:h] where f1 is not null group by f1 having count(f1)>=2"
   
7.     sql = "select top 10 b.* from (" & s & ") a inner join [v$a2:h] b on a.f1=b.f1 order by b.f6 desc"
   
8.     Set rst = conn.Execute(sql)
   
9.     Sheets("Sheet1").Activate: Cells.Clear
   
10.     [a1:h1] = [{"Part Number","Part Description","Primary Category","Secondary Category","Plant","FY17 Volume","Supplier Name","Supplier Code"}]
    
11.     Range("a2").CopyFromRecordset rst
    
12. End Sub

复制代码