数值根据指定条件分解出需要的数值

liulang0808

hujianjian123 发表于 2020-2-1 21:26
老师您好  我的计算想法是这样的   把需要分解的数值优先分解成大的长度 ，其次是小长度 ，   另外 ...

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     If Target.Address(0, 0) = "B1" Then
   
3.         If Len(Target) > 0 Then
   
4.             Z = Target
   
5.             Set d = CreateObject("scripting.dictionary")
   
6.             For j = 2 To 7
   
7.                 For i = j + 1 To 7
   
8.                     sm = Cells(2, i) + Cells(2, j)
   
9.                     If Not d.exists(sm) Then
   
10.                         Set d(sm) = Union(Cells(3, i), Cells(3, j))
    
11.                     End If
    
12.                 Next i
    
13.             Next j
    
14.             Application.EnableEvents = False
    
15.             [b3:g3].Value = ""
    
16.             For i = 2 To 6
    
17.                 Z = Val(Z)
    
18.                 If d.exists(Z) Then
    
19.                     d(Z).Value = 1
    
20.                     GoTo l1
    
21.                 End If
    
22.                 Cells(3, i) = Int(Z / Cells(2, i))
    
23.                 Z = Z - Cells(3, i) * Cells(2, i)
    
24.             Next i
    
25.             If Z = 0 Then
    
26.                 Cells(3, 7) = 0
    
27.             Else
    
28.                 x = Int(Z / Cells(2, 7))
    
29.                 If Z = x * Cells(2, 7) Then
    
30.                     Cells(3, 7) = x
    
31.                 Else
    
32.                     Cells(3, 7) = x + 1
    
33.                 End If
    
34.             End If
    
35. l1:
    
36.             Application.EnableEvents = True
    
37.         End If
    
38.     End If
    
39. End Sub

复制代码

liulang0808

做了修改，供参考。。。。。。

hujianjian123

liulang0808 发表于 2020-2-2 08:16
做了修改，供参考。。。。。。

谢谢老师   老师辛苦了
       昨天晚上有位朋友帮我i写好了VBA ，我在表2里面把计算规则罗列了一部分，朋友根据计算规则写的vba，但是他帮我写成了按钮执行方式，算法是满足要求了，但是执行起来不方便，老师您帮忙看下，能否把按钮去掉，谢谢！

liulang0808

hujianjian123 发表于 2020-2-2 17:44
谢谢老师   老师辛苦了
       昨天晚上有位朋友帮我i写好了VBA ，我在表2里面把计算规则罗列了一部分， ...

看到这个，才真明白楼主要解决什么问题
不是通过代码直接处理
而是根据第二张表里列出来的结果进行设置？

1. Private Sub CommandButton1_Click()
   
2.     Dim i&, i1&, i2&
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     Set dic1 = CreateObject("scripting.dictionary")
   
5.     i = 2
   
6.     Do
   
7.         If Len(Trim(Sheets("sheet1").Cells(2, i))) = 0 Then Exit Do
   
8.         Sheets("sheet1").Cells(3, i) = ""
   
9.         If Not dic.exists(CDbl(Sheets("sheet1").Cells(2, i))) Then
   
10.             dic.Add CDbl(Sheets("sheet1").Cells(2, i)), i
    
11.         End If
    
12.         i = i + 1
    
13.     Loop
    
14.     i = 1
    
15.     Do
    
16.         If Len(Trim(Sheets("sheet2").Cells(i, 1))) = 0 Then Exit Do
    
17.         If Sheets("sheet2").Cells(i, 1) = Sheets("sheet1").Cells(1, 2) Then
    
18.             mbsz = Split(Sheets("sheet2").Cells(i, 2), "+")
    
19.             For i1 = 0 To UBound(mbsz)
    
20.                 If dic.exists(CDbl(mbsz(i1))) Then
    
21.                     i3 = dic(CDbl(mbsz(i1)))
    
22.                     Sheets("sheet1").Cells(3, i3) = Sheets("sheet1").Cells(3, i3) + 1
    
23.                 End If
    
24.             Next
    
25.             Exit Do
    
26.         End If
    
27.         i = i + 1
    
28.     Loop
    
29. End Sub
    
30. 
    
31. 
    
32. 
    
33. Private Sub Worksheet_Change(ByVal Target As Range)
    
34.     If Target.Address(0, 0) = "B1" Then
    
35.         If Len(Target) > 0 Then Call CommandButton1_Click
    
36.     End If
    
37. End Sub
    

复制代码

liulang0808

按照楼主的意图，启用事件调用你朋友的代码
看看是否合适吧

hujianjian123

liulang0808 发表于 2020-2-2 19:23
按照楼主的意图，启用事件调用你朋友的代码
看看是否合适吧

谢谢老师  老师辛苦了 ，就是这个意思，阿泰谢谢了

lsdongjh

5.7=0.6+0.6+0.5+2+2

lsdongjh

递归解法，

1. Option Explicit
   
2. 
   
3. Dim arrResult As Variant
   
4. 
   
5. Sub Test()
   
6.     Dim arr As Variant, brr As Variant
   
7.     Dim dblVal As Double, dblOld As Double, blGet As Boolean
   
8.     arr = Sheet1.Range("B2:G2")
   
9.     ReDim brr(1 To 1, 1 To 6) As Long
   
10.     dblVal = Round(Sheet1.Range("B1").Value, 1)
    
11.    
    
12.     blGet = GetNum(arr, dblVal, brr, 1)
    
13.    
    
14.     If blGet Then
    
15.         MsgBox "找到最佳解法！"
    
16.     Else
    
17.         MsgBox "没有最佳解法，即将尝试进行接近值的解法！"
    
18.    
    
19.         Do While blGet = False
    
20.             dblVal = dblVal + 0.1
    
21.             ReDim brr(1 To 1, 1 To 6) As Long
    
22.             blGet = GetNum(arr, dblVal, brr, 1)
    
23.         Loop
    
24.         
    
25.         MsgBox "找到最接近的解法！"
    
26.     End If
    
27.         
    
28.     Sheet1.Range("B3").Resize(1, 6) = arrResult
    
29. End Sub
    
30. 
    
31. 
    
32. Function GetNum(arr As Variant, dblSum As Double, brr As Variant, lngColID As Long) As Boolean
    
33.     Dim dblTemp As Double, arrTemp As Variant
    
34.     Dim blOK As Boolean, lngID As Long
    
35.    
    
36.     arrTemp = brr
    
37.     arrTemp(1, lngColID) = arrTemp(1, lngColID) + 1
    
38.    
    
39.     dblTemp = Application.WorksheetFunction.SumProduct(arr, arrTemp)
    
40.    
    
41.     If dblTemp = dblSum Then
    
42.         arrResult = arrTemp
    
43.         GetNum = True
    
44.         Exit Function
    
45.     ElseIf dblTemp > dblSum Then
    
46.         arrTemp(1, lngColID) = arrTemp(1, lngColID) - 1
    
47.         lngColID = lngColID + 1
    
48.         If lngColID > UBound(arrTemp, 2) Then
    
49.             lngColID = 0
    
50.             For lngID = UBound(arrTemp, 2) - 1 To 1 Step -1
    
51.                 If arrTemp(1, lngID) > 0 Then
    
52.                     arrTemp(1, lngID) = arrTemp(1, lngID) - 1
    
53.                     lngColID = lngID + 1
    
54.                     Exit For
    
55.                 End If
    
56.             Next
    
57.             If lngColID = 0 Then
    
58.                 GetNum = False
    
59.                 Exit Function
    
60.             End If
    
61.         End If
    
62.     End If
    
63.    
    
64.     blOK = blOK Or GetNum(arr, dblSum, arrTemp, lngColID)
    
65.    
    
66.     GetNum = blOK
    
67. End Function
    

复制代码

yjh_27

根据客户要求长度选择合适灯条
http://club.excelhome.net/thread-1448853-1-1.html
(出处: ExcelHome技术论坛)

hujianjian123

lsdongjh 发表于 2020-2-3 16:54
递归解法，

老师您好 ，您这段代码也完全满足计算要求，但是需要按钮来执行呀，还请老师帮忙去掉代码.谢谢