VBA字典改写用数组方法计算

laoau128

VBA字典改写用数组方法计算

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, sum, i, j, m
  arr = [b2:c13]
  Call dsort(arr, 1, UBound(arr, 1) - 1, 1, True)
  For i = 1 To UBound(arr, 1) - 1
    For j = i To UBound(arr, 1) - 1
      sum = sum + arr(j, 2)
      If arr(j, 1) <> arr(j + 1, 1) Then
        m = m + 1: arr(m, 1) = arr(i, 1): arr(m, 2) = sum
        sum = 0: i = j: Exit For
      End If
  Next j, i
  [e11].Resize(m, UBound(arr, 2)) = arr
End Sub

Function dsort(arr, first, last, key, order)
  Dim i, j, k, t
  For i = first To last - 1
    For j = i + 1 To last
      If arr(i, key) < arr(j, key) Xor order 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
End Function

gufengaoyue

1. Sub 数组方法如何写()
   
2. On Error Resume Next
   
3. Dim arr, brr(), x%, crr, b&
   
4.     arr = [a1].CurrentRegion
   
5.     ReDim crr(1 To UBound(arr), 1 To 2)
   
6.     For a = 2 To UBound(arr)
   
7.         x = 0
   
8.         x = WorksheetFunction.Match(arr(a, 2), brr, False)
   
9.         If x = 0 Then
   
10.             b = b + 1
    
11.             ReDim Preserve brr(1 To b)
    
12.             brr(b) = arr(a, 2)
    
13.             x = b
    
14.         End If
    
15.         crr(x, 1) = arr(a, 2)
    
16.         crr(x, 2) = crr(x, 2) + arr(a, 3)
    
17.     Next
    
18. [e11].Resize(b, 2) = crr
    
19. End Sub

复制代码

一把小刀闯天下

'数据量小不用排序也可以，，，

Option Explicit

Sub test()
  Dim arr, i, j, m
  arr = [b2:c12]
  For i = 1 To UBound(arr, 1)
    If Len(arr(i, 1)) Then
      m = m + 1: arr(m, 1) = arr(i, 1)
      arr(m, 2) = arr(i, 2)
      For j = i + 1 To UBound(arr, 1)
        If Len(arr(j, 1)) Then
          If arr(j, 1) = arr(m, 1) Then
            arr(m, 2) = arr(m, 2) + arr(j, 2): arr(j, 1) = vbNullString
          End If
        End If
      Next
    End If
  Next
  [e18].Resize(m, UBound(arr, 2)) = arr
End Sub

laoau128

一把小刀闯天下 发表于 2018-12-6 14:59
'数据量小不用排序也可以，，，

Option Explicit

你为什么要排序了，不排序行不行

laoau128

gufengaoyue 发表于 2018-12-6 14:55

不用match函数，用两个循环如何写

一把小刀闯天下

laoau128 发表于 2018-12-6 15:03
你为什么要排序了，不排序行不行

4楼没给你排

当数据量很大的时候换快排优势马上就能出来，sub中2个循环效率基本等同于单循环，所以效率非常高，，，

gufengaoyue

laoau128 发表于 2018-12-6 15:05
不用match函数，用两个循环如何写

能少用循环就少用。数据多了就慢了。

1. Sub 数组方法如何写()
   
2. On Error Resume Next
   
3. Dim arr, brr(), x%, crr, b&
   
4.     arr = [a1].CurrentRegion
   
5.     ReDim crr(1 To UBound(arr), 1 To 2)
   
6.     For a = 2 To UBound(arr)
   
7.         For x = 1 To b
   
8.             If brr(x) = arr(a, 2) Then Exit For
   
9.         Next
   
10.         If x > b Then
    
11.             b = b + 1
    
12.             ReDim Preserve brr(1 To b)
    
13.             brr(b) = arr(a, 2)
    
14.             x = b
    
15.         End If
    
16.         crr(x, 1) = arr(a, 2)
    
17.         crr(x, 2) = crr(x, 2) + arr(a, 3)
    
18.     Next
    
19. [e11].Resize(b, 2) = crr
    
20. End Sub

复制代码

laoau128

一把小刀闯天下 发表于 2018-12-6 14:59
'数据量小不用排序也可以，，，

Option Explicit

这个排序是否多余了

laoau128

gufengaoyue 发表于 2018-12-6 15:10
能少用循环就少用。数据多了就慢了。

同一个数组arr, 2个循环比较，如何写

你现在写的是arr与brr比较