求助，显示满足条件的数据

ping96055

求助，显示满足条件的数据

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, t, dic(1), n, key
  For i = 0 To UBound(dic)
    Set dic(i) = CreateObject("scripting.dictionary")
  Next
  arr = Range("b2:h" & Cells(Rows.Count, "d").End(xlUp).Row)
  For i = 1 To UBound(arr, 1)
    If Len(arr(i, 2)) = 0 Then arr(i, 2) = arr(i - 1, 2)
    t = arr(i, 2) & "|" & arr(i, 3)
    If dic(0).exists(t) Then
      dic(0)(t) = dic(0)(t) & "," & arr(i, 7)
    Else
      dic(0)(t) = arr(i, 7)
    End If
    dic(1)(t) = dic(1)(t) + arr(i, 1)
  Next
  ReDim arr(1 To dic(0).Count, 1 To 4)
  For Each key In dic(0).keys
    n = n + 1
    t = Split(key, "|"): arr(n, 1) = dic(1)(key)
    arr(n, 2) = t(0): arr(n, 3) = t(1)
    arr(n, 4) = dic(0)(key)
  Next
  With [k2]
    .Resize(Rows.Count - 1, UBound(arr, 2)).ClearContents
    .Resize(n, UBound(arr, 2)) = arr
  End With
End Sub

ping96055

一把小刀闯天下 发表于 2018-8-6 20:45
Option Explicit

Sub test()

高手。完全满足我的要求，谢谢小刀。

ping96055

一把小刀闯天下 发表于 2018-8-6 20:45
Option Explicit

Sub test()

高手，完全满足我的要求

ping96055

运行速度还是蛮快的。

凌空一羽

1. Sub lkyy()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. ar = Range("a1").CurrentRegion
   
4. For i = 2 To UBound(ar)
   
5.     If Not d.exists(ar(i, 4)) Then
   
6.         d(ar(i, 4)) = Array(ar(i, 2), ar(i, 3), ar(i, 4), ar(i, 8))
   
7.     Else
   
8.         k = d(ar(i, 4))
   
9.         k(0) = k(0) + ar(i, 2)
   
10.         k(3) = k(3) & "," & ar(i, 8)
    
11.         d(ar(i, 4)) = k
    
12.     End If
    
13. Next
    
14. Range("k2").Resize(d.Count, 4) = Application.Rept(d.items, 1)
    
15. Set d = Nothing
    
16. End Sub

复制代码

任飘渺

Sub test()
    Dim dic As Object, i As Integer, arr, brr()
    Dim n As Integer
    n = 1
    Set dic = CreateObject("scripting.dictionary")
    With Sheet1
        arr = .[a1].CurrentRegion
        ReDim brr(1 To UBound(arr), 1 To 4)
        brr(1, 4) = "生产流水号"
        
        For i = 1 To UBound(arr)
            If arr(i, 3) = "" Then arr(i, 3) = arr(i - 1, 3)
        Next i
        
        For i = 2 To 4
            brr(1, i - 1) = arr(1, i)
        Next i
        
        For i = 2 To UBound(arr)
            x = arr(i, 3) & "-" & arr(i, 4)
            If dic.exists(x) = False Then
                n = n + 1
                dic(x) = n
                brr(n, 1) = arr(i, 2)
                brr(n, 2) = arr(i, 3)
                brr(n, 3) = arr(i, 4)
                brr(n, 4) = arr(i, 8) & ","
            Else
                brr(dic(x), 1) = brr(dic(x), 1) + arr(i, 2)
                brr(dic(x), 4) = brr(dic(x), 4) & arr(i, 8) & ","
            End If
        Next i
        
        For i = 1 To n
              brr(i, 4) = Left(brr(i, 4), Len(brr(i, 4)) - 1)
        Next i
        .[k7].Resize(n, 4) = brr
    End With
End Sub

ping96055

凌空一羽 发表于 2018-8-6 21:25

为什么不能完全显示出来，只显示一部分，程序也在里面

ping96055

搞定，谢谢。参数没改过来。现在完美了