按一定规则进行分摊

shufeabb

other cost split.rar (10.51 KB, 下载次数: 20)

2021-5-12 09:08 上传

点击文件名下载附件

鄂龙蒙

分摊.rar (27.41 KB, 下载次数: 5)

2021-5-12 11:14 上传

点击文件名下载附件

鄂龙蒙

1. Sub 分摊()
   
2.     Dim d, ar, br(), brr, i, j, x, m, n, k, t, s, a
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.    Sheet3.[A3:I10000] = Empty
   
5.     ar = Sheet2.Range("A1").CurrentRegion
   
6.     For i = 2 To UBound(ar)
   
7.         s = Trim(ar(i, 1)) & Trim(ar(i, 3))
   
8.         If d(s) = "" Then
   
9.             m = m + 1
   
10.             ReDim Preserve br(1 To 10, 1 To m)
    
11.             d(s) = m
    
12.             br(1, m) = Trim(ar(i, 1))
    
13.             br(2, m) = Trim(ar(i, 3))
    
14.             br(3, m) = ar(i, 5)
    
15.             br(4, m) = ar(i, 6)
    
16.             br(5, m) = ar(i, 2)
    
17.              If ar(i, 5) <> "WI" Then br(10, m) = ar(i, 2)
    
18.         Else
    
19.             br(5, d(s)) = br(5, d(s)) + ar(i, 2)
    
20.             If ar(i, 5) <> "WI" Then br(10, d(s)) = br(10, d(s)) + ar(i, 2)
    
21.         End If
    
22.     Next
    
23.     d.RemoveAll
    
24.     ar = Sheet3.Range("L2").CurrentRegion
    
25.     For i = 2 To UBound(ar)
    
26.         For j = 2 To UBound(ar, 2)
    
27.              If Not d.exists(Trim(ar(i, 1))) Then
    
28.                 n = 1
    
29.                 ReDim brr(1 To 2, 1 To n)
    
30.             Else
    
31.                 brr = d(Trim(ar(i, 1)))
    
32.                 n = UBound(brr, 2) + 1
    
33.                 ReDim Preserve brr(1 To 2, 1 To n)
    
34.             End If
    
35.             brr(1, n) = Trim(ar(1, j))
    
36.             brr(2, n) = ar(i, j)
    
37.             d(Trim(ar(i, 1))) = brr
    
38.         Next
    
39.     Next
    
40.     k = d.keys
    
41.     t = d.items
    
42.     For j = 1 To m
    
43.         If br(3, j) <> "WI" Then
    
44.             For x = 0 To d.Count - 1
    
45.                 For i = 1 To UBound(t(x), 2)
    
46.                     If CStr(br(1, j)) = CStr(t(x)(1, i)) Then
    
47.                         a = 0
    
48.                         For y = 1 To m
    
49.                             If CStr(br(1, y)) = CStr(t(x)(1, i)) Then a = a + br(10, y)
    
50.                         Next
    
51.                         br(x + 6, j) = t(x)(2, i) / a * br(5, j)
    
52.                     End If
    
53.                 Next
    
54.             Next
    
55.         End If
    
56.     Next
    
57.     Sheet3.[A3].Resize(m, 9) = Application.Transpose(br)
    
58.    Set d = Nothing
    
59. End Sub

复制代码

shufeabb

是VBA啊，希望用M函数，能看懂自己也可以根据实际情况更改一下。

wdx223

deadzlq

PowerQuery参考解法