是否可用VBA实现多层级归属业绩、人力统计

dannalhsu

如附件所示，我有一个预备团队，每一个预备经理名下有若干预备主管，预备主管名下还有职员，职员名下还有顾问等等。层级归属不仅限于四级，实际上上千人的团队会出现五级归属、六级归属甚至更多。本来想根据归属生成虚拟团队名，然后用函数来解决，但真正写起来，单纯的用函数似乎逻辑太复杂，以我的excel功底要统计团队业绩和团队人力有些困难，请教各位大神，是否可用VBA实现这一功能？
团队业绩统计.zip (12.36 KB, 下载次数: 154)

2018-8-31 10:29 上传

点击文件名下载附件

ahnyt

表格这样设计不是很好，可以交流一下吗？看消息

小花鹿

这个有点复杂，可能要用到递归                                                                                       

魂断蓝桥

看到了你的问题，直接用excel不太容易实现，

感觉用数据库比较好，界面可以用excel，数据库是sqlite

上个附件你可以参考一下，只是一个简单的演示，提供一个思路吧。


Sub 建库建表()
Dim cnn As New cConnection
Dim rs As New cRecordset
Dim sql$
    cnn.CreateNewDB ThisWorkbook.Path & "\递归.db", "1"
    cnn.OpenDB ThisWorkbook.Path & "\递归.db", "1"
    sql = "CREATE TABLE T1(ID INTEGER PRIMARY KEY,姓名,职务,父id,业绩)"
    cnn.Execute sql
Set cnn = Nothing
End Sub


新增数据语句

Private Sub CommandButton10_Click()
If Me.TextBox1 = "" Then Exit Sub
Dim cnn As New cConnection, M%, j%
Dim rs As New cRecordset, sql$
cnn.OpenDB ThisWorkbook.Path & "\递归.db", "1"
sql = Me.TextBox1
Me.VSFlexGrid1.Clear 1, 1
If UCase(Left(sql, 1)) = "W" Then
    Me.VSFlexGrid1.Clear
    rs.OpenRecordset sql, cnn, True
    Me.VSFlexGrid1.Rows = rs.RecordCount + 1
        For j = 0 To rs.Fields.Count - 1
                Me.VSFlexGrid1.TextMatrix(0, j + 1) = rs.Fields(j).Name
        Next
        Do While Not rs.EOF
            M = M + 1
                For j = 0 To rs.Fields.Count - 1
                    Me.VSFlexGrid1.TextMatrix(M, j + 1) = rs.Fields(j)
                Next
            rs.MoveNext
        Loop
Else
    cnn.Execute (sql)
    Call UserForm_Initialize
End If
Set rs = Nothing
Set cnn = Nothing
End Sub


递归查询语句

with recursive re as
(select * from t1 where 姓名= 'A' union all
select T1.* from re INNER join T1 on re.id= t1.父id)
select * from re

简单演示一下。

分为4级（经理、主管、员工1级，员工2级）

为了看的更清楚，按照姓名来分组，比如 经理的名字是A ,则属于他这一组的都是A.....




递归.rar (25.27 KB, 下载次数: 59)

2018-9-4 14:23 上传

点击文件名下载附件

opiona

标准的递归解决方案：

代码不多，理论上 层级可以无数

1. Dim DOUX As Double
   
2. Dim INTX As Integer
   
3. 
   
4. Sub opiona()
   
5.     Set SHX = Worksheets(1)
   
6.     MAXROW = SHX.Range("A65536").End(3).Row
   
7.     SHX.Range("E2:F65536").ClearContents
   
8.     For I = 2 To MAXROW
   
9.         DOUX = 0
   
10.         INTX = 0
    
11.         Call DG(SHX.Cells(I, 2).Value)
    
12.         SHX.Cells(I, 5).Value = SHX.Cells(I, 4).Value + DOUX
    
13.         SHX.Cells(I, 6).Value = INTX + 1
    
14.     Next
    
15. End Sub
    
16. 
    
17. Sub DG(INDEX)
    
18.     Set SHX = Worksheets(1)
    
19.     MAXROW = SHX.Range("A65536").End(3).Row
    
20.     For I = 2 To MAXROW
    
21.         If SHX.Cells(I, 3).Value = INDEX Then
    
22.             DOUX = DOUX + SHX.Cells(I, 4).Value
    
23.             INTX = INTX + 1
    
24.             Rem 万恶的递归开始了
    
25.             Call DG(SHX.Cells(I, 2).Value)
    
26.         End If
    
27.     Next
    
28. End Sub

复制代码

opiona

递归设计QQ14885553.rar (14.32 KB, 下载次数: 84)

2018-9-5 13:23 上传

点击文件名下载附件

dannalhsu

魂断蓝桥 发表于 2018-9-4 14:23
看到了你的问题，直接用excel不太容易实现，

感觉用数据库比较好，界面可以用excel，数据库是sqlite

太强大了。我的SQL已经全部还给老师了

dannalhsu

opiona 发表于 2018-9-5 13:23

这个应该可行哎~可是我高估了我的智商，想要应用到我的报表里去却发现我不会改o(╥﹏╥)o 求大神赐教

opiona

是我的代码写的太复杂了么！？？

opiona

又减掉几行

1. Dim DOUX As Double
   
2. Dim INTX As Integer
   
3. 
   
4. Sub opiona()
   
5.     Sheet1.Range("E2:F65536").ClearContents
   
6.     For I = 2 To Sheet1.Range("A65536").End(3).Row
   
7.         DOUX = 0
   
8.         INTX = 0
   
9.         Call DG(Sheet1.Cells(I, 2).Value)
   
10.         Sheet1.Cells(I, 5).Value = Sheet1.Cells(I, 4).Value + DOUX
    
11.         Sheet1.Cells(I, 6).Value = INTX + 1
    
12.     Next
    
13. End Sub
    
14. 
    
15. Sub DG(INDEX)
    
16.     For I = 2 To Sheet1.Range("A65536").End(3).Row
    
17.         If Sheet1.Cells(I, 3).Value = INDEX Then
    
18.             DOUX = DOUX + Sheet1.Cells(I, 4).Value
    
19.             INTX = INTX + 1
    
20.             Rem 万恶的递归开始了
    
21.             Call DG(Sheet1.Cells(I, 2).Value)
    
22.         End If
    
23.     Next
    
24. End Sub

复制代码