[已解决]能否把所有O列为打勾的工作表名（括号内的名字）填到浅绿色区域的相应表格

qinhuan66

求助1：能否把所有工作表的数合计汇总到黄色区域。谢谢

求助2：能否把所有O列为打勾的工作表名（括号内的名字）填到浅绿色区域的相应表格。例如：O19和O22单元格

求助.zip (22.89 KB, 下载次数: 4)

2014-10-30 16:50 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

dsmch

2014-10-30 18:29

1. Sub Macro1()
   
2. Dim arr, brr, crr, d, i%, j&, k%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. brr = Range("a3").CurrentRegion
   
5. ReDim crr(1 To UBound(brr) - 2, 1 To 7)
   
6. For i = 1 To Sheets.Count - 1
   
7.     arr = Sheets(i).Range("a1").CurrentRegion
   
8.     For j = 4 To UBound(arr) - 1
   
9.         If arr(j, 2) = "" Then arr(j, 2) = arr(j - 1, 2)
   
10.         If arr(j, 4) = "" Then arr(j, 4) = arr(j - 1, 4)
    
11.         zf = arr(j, 2) & "," & arr(j, 4) & "," & arr(j, 5)
    
12.         For k = 6 To 12
    
13.             d(zf & "," & arr(3, k)) = d(zf & "," & arr(3, k)) + arr(j, k)
    
14.         Next
    
15.     Next
    
16. Next
    
17. For j = 2 To UBound(brr) - 1
    
18.     If brr(j, 2) = "" Then brr(j, 2) = brr(j - 1, 2)
    
19.     If brr(j, 4) = "" Then brr(j, 4) = brr(j - 1, 4)
    
20.     zf = brr(j, 2) & "," & brr(j, 4) & "," & brr(j, 5)
    
21.     For k = 6 To 12
    
22.         crr(j - 1, k - 5) = d(zf & "," & brr(1, k))
    
23.     Next
    
24. Next
    
25. Range("f4").Resize(UBound(crr), UBound(crr, 2)) = crr
    
26. End Sub

复制代码

跳转到最佳答案楼层

baksy

F4公式，横拉、下拉；
=SUM('2014年8月（江南市）:2014年8月（朱海县)'!F4)

M列 =SUM(F4:L6)

dsmch

表格联系人改为身份证号码比较好，这样容易重名。

qinhuan66

dsmch 发表于 2014-10-30 17:46
表格联系人改为身份证号码比较好，这样容易重名。

呵呵！谢谢提醒

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr, d, i%, j&, k%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. brr = Range("a3").CurrentRegion
   
5. ReDim crr(1 To UBound(brr) - 2, 1 To 7)
   
6. For i = 1 To Sheets.Count - 1
   
7.     arr = Sheets(i).Range("a1").CurrentRegion
   
8.     For j = 4 To UBound(arr) - 1
   
9.         If arr(j, 2) = "" Then arr(j, 2) = arr(j - 1, 2)
   
10.         If arr(j, 4) = "" Then arr(j, 4) = arr(j - 1, 4)
    
11.         zf = arr(j, 2) & "," & arr(j, 4) & "," & arr(j, 5)
    
12.         For k = 6 To 12
    
13.             d(zf & "," & arr(3, k)) = d(zf & "," & arr(3, k)) + arr(j, k)
    
14.         Next
    
15.     Next
    
16. Next
    
17. For j = 2 To UBound(brr) - 1
    
18.     If brr(j, 2) = "" Then brr(j, 2) = brr(j - 1, 2)
    
19.     If brr(j, 4) = "" Then brr(j, 4) = brr(j - 1, 4)
    
20.     zf = brr(j, 2) & "," & brr(j, 4) & "," & brr(j, 5)
    
21.     For k = 6 To 12
    
22.         crr(j - 1, k - 5) = d(zf & "," & brr(1, k))
    
23.     Next
    
24. Next
    
25. Range("f4").Resize(UBound(crr), UBound(crr, 2)) = crr
    
26. End Sub

复制代码

dsmch

………………

qinhuan66

dsmch 发表于 2014-10-30 18:29

好像第二个问题没有做到？
能否把所有O列为打勾的工作表名（括号内的名字）填到浅绿色区域的相应表格

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr, d, i%, j&, k%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. brr = Range("a3").CurrentRegion
   
5. ReDim crr(1 To UBound(brr) - 2, 1 To 8)
   
6. For i = 1 To Sheets.Count - 1
   
7.     dgb = Split(Sheets(i).Name, "（")(1)
   
8.     dm = Left(dgb, Len(dgb) - 1)
   
9.     arr = Sheets(i).Range("a1").CurrentRegion
   
10.     For j = 4 To UBound(arr) - 1
    
11.         If arr(j, 2) = "" Then arr(j, 2) = arr(j - 1, 2)
    
12.         If arr(j, 4) = "" Then arr(j, 4) = arr(j - 1, 4)
    
13.         zf = arr(j, 2) & "," & arr(j, 4) & "," & arr(j, 5)
    
14.         For k = 6 To 12
    
15.             d(zf & "," & arr(3, k)) = d(zf & "," & arr(3, k)) + arr(j, k)
    
16.         Next
    
17.         If arr(j, 15) = "√" Then
    
18.             zf2 = zf & "," & "打勾"
    
19.             If Not d.exists(zf2) Then d(zf2) = dm Else d(zf2) = d(zf2) & ";" & dm
    
20.         End If
    
21.     Next
    
22. Next
    
23. For j = 2 To UBound(brr) - 1
    
24.     If brr(j, 2) = "" Then brr(j, 2) = brr(j - 1, 2)
    
25.     If brr(j, 4) = "" Then brr(j, 4) = brr(j - 1, 4)
    
26.     zf = brr(j, 2) & "," & brr(j, 4) & "," & brr(j, 5)
    
27.     crr(j - 1, 8) = d(zf & "," & "打勾")
    
28.     For k = 6 To 12
    
29.         crr(j - 1, k - 5) = d(zf & "," & brr(1, k))
    
30.     Next
    
31. Next
    
32. Range("f4").Resize(UBound(crr), 7) = crr
    
33. Range("o4").Resize(UBound(crr)) = Application.Index(crr, 0, 8)
    
34. End Sub

复制代码

qinhuan66

dsmch 发表于 2014-10-30 20:31

你好老师！为什么我想生成到F至M列把For k = 6 To 12改成For k = 6 To 14还不行呢？谢谢