先排序再提取每个内条码对应的条码前5个数据

ptjtlt260

数据提取要求：


1. 先对条码列进行排序
2. 以内条码进行分组
3. 提取每个内条码对应的前5个条码、RN列数据
4. 如内条码对应的条码小于5个有几个提取几个

请大侠门帮忙指导！感谢😊

limonet

关键字：order+top 5

ykcbf1100

附件供参考。。。

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Arr As Variant, i%, j%
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    Arr = Cn.Execute("Select distinct 内条码 From [数据表$A:C] Where 内条码<>''").getrows
    For i = 0 To UBound(Arr, 2)
        j = j + 1: StrSQL = StrSQL & " Union All Select top 5 * From [数据表$A:C] Where 内条码='" & Arr(0, i) & "' order by 条码"
        If j = 48 Or i = UBound(Arr, 2) Then
            Range("J" & Range("J" & Rows.Count).End(xlUp).Row + 1).CopyFromRecordset Cn.Execute(Mid(StrSQL, 12))
            j = 0: StrSQL = ""
        End If
    Next i
End Sub

ykcbf1100

参与一下。。。

1. Sub ykcbf() '//2024.5.21
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     r = Cells(Rows.Count, 1).End(3).Row
   
5.     Set Rng = [a2].Resize(r - 1, 3)
   
6.     Rng.Sort [a2], 1
   
7.     arr = Rng.Value
   
8.     For i = 1 To UBound(arr)
   
9.         s = arr(i, 3)
   
10.         If s <> Empty Then
    
11.             If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
12.             d(s)(i) = i
    
13.         End If
    
14.     Next
    
15.     ReDim brr(1 To 10000, 1 To 3)
    
16.     For Each k In d.keys
    
17.         n = 0
    
18.         For Each kk In d(k).keys
    
19.             m = m + 1: n = n + 1
    
20.             If n > 5 Then m = m - 1: Exit For:
    
21.             brr(m, 1) = arr(kk, 1)
    
22.             brr(m, 2) = arr(kk, 2)
    
23.             brr(m, 3) = arr(kk, 3)
    
24.         Next
    
25.     Next
    
26.     [g2:i10000] = ""
    
27.     Columns("g:i").NumberFormatLocal = "@"
    
28.     [g2].Resize(m, 3) = brr
    
29.     Set d = Nothing
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "OK！"
    
32. End Sub
    
33. 
    

复制代码