[已解决]求各位大神帮忙

531tommy

附件中我需要对SHEET1的数据按Sheet2中1行的条件进行归类整合，数据量比较大用数据透视+公式很不方便，求大神帮忙弄个VB 仓存整合.zip (10.09 KB, 下载次数: 6)

2022-5-16 10:16 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hasyh2008

2022-5-16 14:28

不知道你的意思是不是这样的。

Sub tongji()
  Dim D1, D2, D3, It1, It2, It3, K
  Dim Arr, Brr
  Dim Rc%, X%
  Set D1 = CreateObject("scripting.dictionary")
  Set D2 = CreateObject("scripting.dictionary")
  Set D3 = CreateObject("scripting.dictionary")
  Sheet2.Range("A4:D10000")=""
  Arr = Sheet1.Range("A1").CurrentRegion
  For X = 2 To UBound(Arr)
    D1(Arr(X, 2)) = D1(Arr(X, 2)) + 1
    D2(Arr(X, 2)) = D2(Arr(X, 2)) + Arr(X, 6)
    D3(Arr(X, 2)) = D3(Arr(X, 2)) + Arr(X, 1) & "/" & Arr(X, 4) & "/" & Arr(X, 6) & "、"
  Next X
  K = D1.keys
  It1 = D1.items
  It2 = D2.items
  It3 = D3.items
  With Sheet2
    .Cells(4, 1).Resize(UBound(K) + 1, 1) = Application.Transpose(K)
    .Cells(4, 2).Resize(UBound(K) + 1, 1) = Application.Transpose(It1)
    .Cells(4, 3).Resize(UBound(K) + 1, 1) = Application.Transpose(It2)
    .Cells(4, 4).Resize(UBound(K) + 1, 1) = Application.Transpose(It3)
    Rc = .Cells(Rows.Count, 1).End(xlUp).Row
    For X = Rc To 4 Step -1
      If .Cells(X, 2) * 1 < .Cells(1, 2) Or .Cells(X, 3) * 1 < .Cells(1, 4) Then
        Rows(X).Delete
      End If
    Next X
  End With
End Sub

跳转到最佳答案楼层

hasyh2008

不知道你的意思是不是这样的。

Sub tongji()
  Dim D1, D2, D3, It1, It2, It3, K
  Dim Arr, Brr
  Dim Rc%, X%
  Set D1 = CreateObject("scripting.dictionary")
  Set D2 = CreateObject("scripting.dictionary")
  Set D3 = CreateObject("scripting.dictionary")
  Sheet2.Range("A4:D10000")=""
  Arr = Sheet1.Range("A1").CurrentRegion
  For X = 2 To UBound(Arr)
    D1(Arr(X, 2)) = D1(Arr(X, 2)) + 1
    D2(Arr(X, 2)) = D2(Arr(X, 2)) + Arr(X, 6)
    D3(Arr(X, 2)) = D3(Arr(X, 2)) + Arr(X, 1) & "/" & Arr(X, 4) & "/" & Arr(X, 6) & "、"
  Next X
  K = D1.keys
  It1 = D1.items
  It2 = D2.items
  It3 = D3.items
  With Sheet2
    .Cells(4, 1).Resize(UBound(K) + 1, 1) = Application.Transpose(K)
    .Cells(4, 2).Resize(UBound(K) + 1, 1) = Application.Transpose(It1)
    .Cells(4, 3).Resize(UBound(K) + 1, 1) = Application.Transpose(It2)
    .Cells(4, 4).Resize(UBound(K) + 1, 1) = Application.Transpose(It3)
    Rc = .Cells(Rows.Count, 1).End(xlUp).Row
    For X = Rc To 4 Step -1
      If .Cells(X, 2) * 1 < .Cells(1, 2) Or .Cells(X, 3) * 1 < .Cells(1, 4) Then
        Rows(X).Delete
      End If
    Next X
  End With
End Sub

531tommy

hasyh2008 发表于 2022-5-16 14:28
不知道你的意思是不是这样的。

Sub tongji()

是啊，十分感谢

hasyh2008

1. <div class="blockcode"><blockquote>Sub tongji()
   
2.   Dim D1, D2, D3, It1, It2, It3, K, I%
   
3.   Dim Arr, Brr(1 To 1000, 1 To 4)
   
4.   Dim Rc%, X%
   
5.   Set D1 = CreateObject("scripting.dictionary")
   
6.   Set D2 = CreateObject("scripting.dictionary")
   
7.   Set D3 = CreateObject("scripting.dictionary")
   
8.   Sheet2.Range("A4:D1000") = ""
   
9.   Arr = Sheet1.Range("A1").CurrentRegion
   
10.   For X = 2 To UBound(Arr)
    
11.     D1(Arr(X, 2)) = D1(Arr(X, 2)) + 1
    
12.     D2(Arr(X, 2)) = D2(Arr(X, 2)) + Arr(X, 6)
    
13.     D3(Arr(X, 2)) = D3(Arr(X, 2)) + Arr(X, 1) & "/" & Arr(X, 4) & "/" & Arr(X, 6) & "、"
    
14.   Next X
    
15.   K = D1.keys
    
16.   It1 = D1.items
    
17.   It2 = D2.items
    
18.   It3 = D3.items
    
19.   I = 1
    
20.   With Sheet2
    
21.     For X = 0 To UBound(K)
    
22.       If It1(X) > .Cells(1, 2) And It2(X) > .Cells(1, 4) Then
    
23.         Brr(I, 1) = K(X): Brr(I, 2) = It1(X)
    
24.         Brr(I, 3) = It2(X): Brr(I, 4) = It3(X)
    
25.         I = I + 1
    
26.       End If
    
27.     Next X
    
28.     .Range("A4").Resize(I, 4) = Brr
    
29.   End With
    
30. End Sub

复制代码