|
楼主 |
发表于 2017-12-18 15:42
|
显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
- Public d
- Public a
- Public arr
- Public m
- Sub lqxs_zd()
- Application.ScreenUpdating = False
- ActiveSheet.UsedRange.Offset(0, 2).ClearContents
- Set d = CreateObject("scripting.dictionary")
- arr = [a1].CurrentRegion
- a = 3
- m = Application.InputBox("请输入数字:", "凑数", 10, , , , , 1)
- For j = 2 To UBound(arr)
- If arr(j, 1) < m Then
- d(j) = arr(j, 1)
- dg j
- If d.Count > 0 Then d.Remove j
- Else
- If arr(j, 1) = m Then
- Cells(1, a) = arr(j, 1)
- a = a + 1
- End If
- End If
-
- Next j
- Application.ScreenUpdating = True
- End Sub
- Sub dg(y)
- For j = y + 1 To UBound(arr)
- sm = WorksheetFunction.Sum(d.items)
- If sm + arr(j, 1) = m Then
- d(j) = arr(j, 1)
- Cells(1, a).Resize(d.Count) = WorksheetFunction.Transpose(d.items)
- a = a + 1
- d.Remove j
- Else
- If sm + arr(j, 1) < m Then
- d(j) = arr(j, 1)
- dg j
- End If
- End If
- If d.exists(j) Then d.Remove j
- Next j
- End Sub
复制代码 |
评分
-
2
查看全部评分
-
|