求助：如何联动人员分布，各位高手指点下，谢谢

jooyl

用什么方法可以将附件中sheet2，与sheet1联动，就是在sheet1中调整，sheet2中会自动跟着变，可否做个小样？万分感谢！！
（用透视表只能算出数字，达不到效果）

zpy2

http://club.excelhome.net/thread-1462035-1-1.html
这种？

sunya_0529

这个需求只能用VBA来解决了，效果如下图所示——




代码如下所示——

1. Option Explicit
   
2. 
   
3. Sub 提取分布名单()
   
4. 'On Error Resume Next
   
5. Dim dic As Object, rng As Range, a(1 To 19, 2), b(9999, 4), c, d, h%, i%, j%, k%
   
6. Dim str1$
   
7. Set dic = CreateObject("Scripting.Dictionary")
   
8. With Sheets("1人员明细表")
   
9.   For Each rng In .Range("A2:A" & .[A65536].End(xlUp).Row)
   
10.     If Not dic.exists(rng.Value) Then
    
11.       h = h + 1
    
12.       dic.Add rng.Value, ""
    
13.       a(h, 0) = rng.Value
    
14.       a(h, 1) = IIf(rng.Offset(0, 1).Value = "安全", rng.Offset(0, 2).Value, "")
    
15.       a(h, 2) = IIf(rng.Offset(0, 1).Value = "安全", "", rng.Offset(0, 2).Value)
    
16.     Else
    
17.       a(h, 1) = a(h, 1) & IIf(rng.Offset(0, 1).Value = "安全", IIf(Len(a(h, 1)) > 0, ",", "") & rng.Offset(0, 2).Value, "")
    
18.       a(h, 2) = a(h, 2) & IIf(rng.Offset(0, 1).Value = "安全", "", IIf(Len(a(h, 2)) > 0, ",", "") & rng.Offset(0, 2).Value)
    
19.     End If
    
20.   Next
    
21. End With
    
22. Set dic = Nothing
    
23. For i = 1 To UBound(a)
    
24.   b(k, 0) = a(i, 0)
    
25.   c = Split(a(i, 1), ",")
    
26.   d = Split(a(i, 2), ",")
    
27.   For j = 0 To Application.Max(Application.RoundUp((UBound(c) + 1) / 2, 0) - 1, Application.RoundUp((UBound(d) + 1) / 2, 0) - 1, 0)
    
28.     If UBound(c) >= j * 2 Then b(k, 1) = c(j * 2)
    
29.     If UBound(c) >= j * 2 + 1 Then b(k, 2) = c(j * 2 + 1)
    
30.     If UBound(d) >= j * 2 Then b(k, 3) = d(j * 2)
    
31.     If UBound(d) >= j * 2 + 1 Then b(k, 4) = d(j * 2 + 1)
    
32.     k = k + 1
    
33.   Next j
    
34. Next i
    
35. With ActiveSheet
    
36.   .[A:E].Clear
    
37.   .[A1] = "公司人员分布"
    
38.   .[A1:E1].Merge
    
39.   .[A2] = "项目名称"
    
40.   .[B2] = "安全"
    
41.   .[B2:C2].Merge
    
42.   .[D2] = "办公室"
    
43.   .[D2:E2].Merge
    
44.   .[A1:E2].HorizontalAlignment = xlCenter
    
45.   '.[A1:E2].VerticalAlignment = xlCenter
    
46.   .[A3].Resize(UBound(b), 5) = b
    
47. End With
    
48. End Sub

复制代码

wangzqxa

留个脚印，谢谢