请教老师：求汇总后匹配的多步合一代码。谢谢！

ak47ok

如题、详见附件，有劳高手！

huang1314wei

1. Sub text()
   
2.     Dim arr(1 To 32, 1 To 2), brr, i%, d, j%, m%, r, ws As Worksheet
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     For i = 1 To 32
   
5.         arr(i, 1) = Application.Dec2Bin(32 - i, 5)
   
6.         arr(i, 2) = 33 - i
   
7.         d(arr(i, 1)) = arr(i, 2)
   
8.     Next
   
9.     Range("E2:S11").ClearContents
   
10.     Columns("C:D").ClearContents
    
11.     brr = Range("E2:S11")
    
12.     For i = 1 To UBound(brr)
    
13.         For j = 1 To UBound(brr, 2)
    
14.             For m = 1 To 5
    
15.                 Set ws = Worksheets(m)
    
16.                 r = IIf(ws.Cells(i + 1, j + 4).Value = "", "0", ws.Cells(i + 1, j + 4).Value)
    
17.                 brr(i, j) = brr(i, j) & r
    
18.             Next
    
19.             brr(i, j) = d(brr(i, j))
    
20.         Next
    
21.     Next
    
22.     Range("E2:S11") = brr
    
23.     Range("C2").Resize(32, 2) = arr
    
24.     Columns(3).NumberFormatLocal = "00000"
    
25. End Sub

复制代码

huang1314wei

看一下是不是符合你的一步到位要求

求汇总后匹配的多步合一代码.rar (26.64 KB, 下载次数: 6)

2015-9-6 22:27 上传

点击文件名下载附件

ak47ok

huang1314wei 发表于 2015-9-6 22:28
看一下是不是符合你的一步到位要求

正解@，老师的代码真高效，看来一时半会我是消化不了的，
再贪心点，还能增加一步吗？

再增加一步：

就是前5表直接用原始数据（因为原附件的前5表的0、1都从原始数据换算得到的）：

如果前5表的单元格值>0的、则为1，否则为0，

其他操作与前相同。

上个附件，谢谢！

yjh_27

ak47ok 发表于 2015-9-6 22:51
正解@，老师的代码真高效，看来一时半会我是消化不了的，
再贪心点，还能增加一步吗？

1. r = IIf(ws.Cells(i + 1, j + 4).Value > 0, 1, 0)

复制代码

直接用二进制计算：

1. For j = 1 To UBound(brr, 2)
   
2.             For m = 1 To 5
   
3.                 Set ws = Worksheets(m)
   
4.                 r = IIf(ws.Cells(i + 1, j + 4).Value > 0, 1, 0)
   
5.                 brr(i, j) = brr(i, j) + r * 2 ^ (5 - m)
   
6.             Next
   
7.             brr(i, j) = brr(i, j) + 1
   
8.         Next

复制代码

huang1314wei

ak47ok 发表于 2015-9-6 22:51
正解@，老师的代码真高效，看来一时半会我是消化不了的，
再贪心点，还能增加一步吗？

可以的，用楼上yjh_27的代码，只需要改一句

1. r = IIf(ws.Cells(i + 1, j + 4).Value > 0, 1, 0)

复制代码

就可以了
同时，换算部分可以直接二进制计算，这样连字典都省了，代码更简洁
完整代码如下：

1. Sub text()
   
2.     Dim brr, i%, j%, m%, r, ws As Worksheet
   
3.     Range("E2:S11").ClearContents
   
4.     brr = Range("E2:S11")
   
5.     For i = 1 To UBound(brr)
   
6.         For j = 1 To UBound(brr, 2)
   
7.             For m = 1 To 5
   
8.                 Set ws = Worksheets(m)
   
9.                 r = IIf(ws.Cells(i + 1, j + 4).Value > 0, 1, 0)
   
10.                 brr(i, j) = brr(i, j) + r * 2 ^ (5 - m)
    
11.             Next
    
12.             brr(i, j) = brr(i, j) + 1
    
13.         Next
    
14.     Next
    
15.     Range("E2:S11") = brr
    
16. End Sub

复制代码