用VBA分别计算第1次采购价和最后一次采购价

laoau138

用VBA分别计算第1次采购价和最后一次采购价

laoau138

Sub 第1次采购价()
Dim i&, j&
m = [a65536].End(3).Row + 1
arr = Range("a2:c" & m)
brr = Application.Index(arr, , 2)
ReDim crr(1 To UBound(arr), 1 To 2)
For i = 1 To UBound(arr) - 1
    If brr(i, 1) <> "" Then x = x + 1: crr(x, 1) = brr(i, 1)
    For j = i + 1 To UBound(arr)
        If brr(j, 1) = brr(i, 1) Then brr(j, 1) = ""
    Next
Next

For i = 1 To x
    For j = 1 To UBound(arr)
        If arr(j, 2) = crr(i, 1) Then
            crr(i, 2) = arr(j, 3)
             Exit For
        End If
    Next
Next
[e2].Resize(x, 2) = crr
End Sub

Sub 第2次采购价()
Dim i&, j&
m = [a65536].End(3).Row + 1
arr = Range("a2:c" & m)
brr = Application.Index(arr, , 2)
ReDim crr(1 To UBound(arr), 1 To 2)
For i = 1 To UBound(arr) - 1
    If brr(i, 1) <> "" Then x = x + 1: crr(x, 1) = brr(i, 1)
    For j = i + 1 To UBound(arr)
        If brr(j, 1) = brr(i, 1) Then brr(j, 1) = ""
    Next
Next

For i = 1 To x
    For j = UBound(arr) To 1 Step -1
        If arr(j, 2) = crr(i, 1) Then
            crr(i, 2) = arr(j, 3)
             Exit For
        End If
    Next
Next
[i2].Resize(x, 2) = crr
End Sub

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, s&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("a1").CurrentRegion
   
5. ReDim brr(1 To UBound(arr), 1 To 3)
   
6. For i = 2 To UBound(arr)
   
7.     If Not d.exists(arr(i, 2)) Then
   
8.         s = s + 1
   
9.         d(arr(i, 2)) = s
   
10.         brr(s, 1) = arr(i, 2)
    
11.         brr(s, 2) = arr(i, 3)
    
12.         brr(s, 3) = arr(i, 3)
    
13.     Else
    
14.         n = d(arr(i, 2))
    
15.         brr(n, 3) = arr(i, 3)
    
16.     End If
    
17. Next
    
18. [e21:g21] = Array("品名", "第一次采购价", "最后一次采购价")
    
19. Range("e22").Resize(s, 3) = brr
    
20. End Sub

复制代码

emmahhm

好聪明的方案，学习了