[已解决]根据条件内容计算

ms967967

C列的内容分别除以数据里C:H的值，能整除的将相应的除数放在E列
附件在二楼

最佳答案

月排行榜 / 总排行榜

dsmch

2014-10-18 20:21

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Dim arr, brr, crr, d
   
4. Set d = CreateObject("scripting.dictionary")
   
5. arr = Sheet1.Range("a1").CurrentRegion
   
6. brr = Sheet2.Range("a1").CurrentRegion
   
7. ReDim crr(1 To UBound(arr) - 1, 1 To 1)
   
8. For i = 2 To UBound(brr)
   
9.     d(brr(i, 1)) = i
   
10. Next
    
11. For i = 2 To UBound(arr)
    
12.     n = d(arr(i, 1)): p = ""
    
13.     For j = 3 To UBound(brr, 2)
    
14.         If brr(n, j) <> "" And arr(i, 3) / brr(n, j) = arr(i, 3) \ brr(n, j) Then p = p & "," & brr(n, j)
    
15.     Next
    
16.     crr(i - 1, 1) = Mid(p, 2)
    
17. Next
    
18. Sheet1.Range("e2").Resize(UBound(crr)) = crr
    
19. End Sub

复制代码

跳转到最佳答案楼层

ms967967

按条件计算.rar (8.17 KB, 下载次数: 8)

2014-10-18 19:49 上传

点击文件名下载附件

这儿有肥猫

你模拟的结果有问题，请看附件,1在任何情况下都不应该被遗漏

这儿有肥猫

另外，求助宏的话，起码应该上传个xlsm的文件，方便答疑的人

1. Sub a()
   
2. Dim i&, j&, arr, brr, m&, n&, crr(), s&, dic As Object
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. arr = Sheets("数据").Range("c2:h" & Sheets("数据").Cells(Rows.Count, 1).End(3).Row)
   
5. brr = Sheets("内容").Range("c2:c" & Sheets("内容").Cells(Rows.Count, 1).End(3).Row)
   
6. For i = 1 To UBound(brr)
   
7.     n = 0
   
8.     For j = 1 To UBound(arr)
   
9.         For m = 1 To UBound(arr, 2)
   
10.             If arr(j, m) <> "" Then
    
11.                If brr(i, 1) Mod arr(j, m) = 0 Then
    
12.                   n = n + 1
    
13.                   ReDim Preserve crr(1 To n)
    
14.                   crr(n) = arr(j, m)
    
15.                End If
    
16.             End If
    
17.         Next
    
18.     Next
    
19.     For s = 1 To UBound(crr)
    
20.         dic(crr(s)) = ""
    
21.     Next
    
22.    
    
23.     Sheets("内容").Cells(i + 1, 5) = Join(dic.keys, ",")
    
24.    
    
25.    
    
26.     dic.RemoveAll
    
27. Next
    
28. Set dic = Nothing
    
29. End Sub
    

复制代码

dsmch

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Dim arr, brr, crr, d
   
4. Set d = CreateObject("scripting.dictionary")
   
5. arr = Sheet1.Range("a1").CurrentRegion
   
6. brr = Sheet2.Range("a1").CurrentRegion
   
7. ReDim crr(1 To UBound(arr) - 1, 1 To 1)
   
8. For i = 2 To UBound(brr)
   
9.     d(brr(i, 1)) = i
   
10. Next
    
11. For i = 2 To UBound(arr)
    
12.     n = d(arr(i, 1)): p = ""
    
13.     For j = 3 To UBound(brr, 2)
    
14.         If brr(n, j) <> "" And arr(i, 3) / brr(n, j) = arr(i, 3) \ brr(n, j) Then p = p & "," & brr(n, j)
    
15.     Next
    
16.     crr(i - 1, 1) = Mid(p, 2)
    
17. Next
    
18. Sheet1.Range("e2").Resize(UBound(crr)) = crr
    
19. End Sub

复制代码

ms967967

这儿有肥猫 发表于 2014-10-18 20:13
另外，求助宏的话，起码应该上传个xlsm的文件，方便答疑的人

感谢指点，下次会注意文件格式，此题5楼答案是我的要求

su45

最佳已出来了，那咱看看