大话西游2 盘古石 计算器 EXCEL-VBA+Gemini

大话西游2 盘古石 计算器 EXCEL-VBA+Gemini

动画

 

表格链接:https://pan.baidu.com/s/1qZyZCZwZgz3WU3sy5rYqIQ?pwd=3956 提取码:3956

2025-12-14 大话西游2 盘古石计算器

主要计算大话西游2 盘古石 的组合，使用VBA代码  递归循环 算法 计算 盘古石的属性 火 雷 水  风 ，组合相加到一起，达到需要的取值区间


 

  1 Sub RecursiveCombination_Helper(data As Variant, indices() As Long, level As Long, startIndex As Long, comboCount As Long, low As Double, high As Double, Fire As Double, Thunder As Double, Water As Double, Wind As Double, ByRef resultsCollection As Collection, minMaxValues() As Double)
  2     
  3     Dim i As Long
  4     Dim remainingCount As Long
  5     remainingCount = comboCount - level + 1
  6     
  7     ' 定义容错值 (0.0001，用于边界检查，解决浮点数误差)
  8     Const EPSILON As Double = 0.0001
  9     ' 定义四舍五入的位数 (与数据精度匹配，例如 2 位小数)
 10     Const ROUND_DIGITS As Long = 2
 11     
 12     ' ----------------------------------------------------------------------
 13     ' *** 优化剪枝：基于理论极限 (引入容错值 EPSILON) ***
 14     ' ----------------------------------------------------------------------
 15     If remainingCount > 0 Then
 16         Dim currentSum As Double
 17         Dim minPossible As Double, maxPossible As Double
 18         Dim c As Long
 19         
 20         For c = 1 To 4
 21             Select Case c
 22                 Case 1: currentSum = Fire
 23                 Case 2: currentSum = Thunder
 24                 Case 3: currentSum = Water
 25                 Case 4: currentSum = Wind
 26             End Select
 27             
 28             Dim minIndex As Long: minIndex = (c * 2) - 1
 29             Dim maxIndex As Long: maxIndex = (c * 2)
 30             
 31             minPossible = currentSum + remainingCount * minMaxValues(minIndex)
 32             maxPossible = currentSum + remainingCount * minMaxValues(maxIndex)
 33             
 34             ' 1. 理论上限剪枝 (防达不到 low) - 略微放宽边界
 35             ' 只有当理论最大值远低于下限时才剪枝
 36             If maxPossible < low - EPSILON Then
 37                  Exit Sub
 38             End If
 39             
 40             ' 2. 理论下限剪枝 (防超过 high) - 略微放宽边界
 41             ' 只有当理论最小值远高于上限时才剪枝
 42             If minPossible > high + EPSILON Then
 43                  Exit Sub
 44             End If
 45             
 46             ' 3. 当前总和剪枝 (防止累加值溢出)
 47             ' 只有当当前总和远超上限时才剪枝
 48             If currentSum > high + EPSILON Then
 49                  Exit Sub
 50             End If
 51         Next c
 52     End If
 53     ' ----------------------------------------------------------------------
 54     
 55     If level > comboCount Then
 56         ' *** 最终检查：使用 Round() 函数解决浮点数精度问题 ***
 57         If Round(Fire, ROUND_DIGITS) >= low And Round(Fire, ROUND_DIGITS) <= high And _
 58            Round(Thunder, ROUND_DIGITS) >= low And Round(Thunder, ROUND_DIGITS) <= high And _
 59            Round(Water, ROUND_DIGITS) >= low And Round(Water, ROUND_DIGITS) <= high And _
 60            Round(Wind, ROUND_DIGITS) >= low And Round(Wind, ROUND_DIGITS) <= high Then
 61 
 62             Dim combination As String: combination = ""
 63             For i = 1 To comboCount: combination = combination & indices(i) & ", ": Next i
 64             combination = Left(combination, Len(combination) - 2)
 65             
 66             Dim average As Double
 67             average = (Fire + Thunder + Water + Wind) / 4
 68             
 69             ' 存储结果，属性值也进行Round以保证输出和检查的一致性
 70             resultsCollection.Add Array(combination, Round(Fire, ROUND_DIGITS), Round(Thunder, ROUND_DIGITS), Round(Water, ROUND_DIGITS), Round(Wind, ROUND_DIGITS), average)
 71         End If
 72         Exit Sub
 73     End If
 74 
 75     ' 递归遍历
 76     For i = startIndex + 1 To UBound(data, 1) - (comboCount - level)
 77         indices(level) = i
 78         RecursiveCombination_Helper data, indices, level + 1, i, comboCount, low, high, Fire + data(i, 1), Thunder + data(i, 2), Water + data(i, 3), Wind + data(i, 4), resultsCollection, minMaxValues
 79     Next i
 80 End Sub
 81 Function GetMinMaxValues(data As Variant) As Double()
 82     ' 数组索引: 1=Min Fire, 2=Max Fire, 3=Min Thunder, 4=Max Thunder, ...
 83     Dim minMaxValues(1 To 8) As Double
 84     Dim numRows As Long: numRows = UBound(data, 1)
 85 
 86     ' 初始化：Min 设为最大，Max 设为最小
 87     Dim i As Long
 88     For i = 1 To 8 Step 2
 89         minMaxValues(i) = 1E+308        ' 初始最小值
 90         minMaxValues(i + 1) = -1E+308   ' 初始最大值
 91     Next i
 92 
 93     ' 遍历数据计算 Min/Max
 94     Dim r As Long, c As Long
 95     For r = 1 To numRows
 96         For c = 1 To 4 ' c=1:Fire, c=2:Thunder, c=3:Water, c=4:Wind
 97             Dim val As Double: val = data(r, c)
 98             Dim minIndex As Long: minIndex = (c * 2) - 1
 99             Dim maxIndex As Long: maxIndex = (c * 2)
100             
101             If val < minMaxValues(minIndex) Then minMaxValues(minIndex) = val
102             If val > minMaxValues(maxIndex) Then minMaxValues(maxIndex) = val
103         Next c
104     Next r
105     
106     GetMinMaxValues = minMaxValues
107 End Function
108 ' 快速排序 QuickSort (按平均值, 索引 5 降序排序)
109 Sub QuickSort(a() As Variant, L As Long, r As Long)
110     ' 排序基于平均值 (索引 5)
111     Dim i As Long, j As Long, pivotValue As Double, temp As Variant
112     i = L: j = r
113     pivotValue = a(Int((L + r) / 2))(5)
114     
115     Do While i <= j
116         ' 降序排序 (从大到小)
117         Do While a(i)(5) > pivotValue: i = i + 1: Loop
118         Do While a(j)(5) < pivotValue: j = j - 1: Loop
119         
120         If i <= j Then
121             temp = a(i): a(i) = a(j): a(j) = temp
122             i = i + 1: j = j - 1
123         End If
124     Loop
125     
126     If L < j Then QuickSort a, L, j
127     If i < r Then QuickSort a, i, r
128 End Sub
129 
130 
131 Sub 盘古石计算器_递归()
132     Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
133     
134     Dim data As Variant
135     Dim indices() As Long
136     Dim resultsCollection As New Collection
137     Dim comboCount As Long
138     Dim low As Double, high As Double
139     Dim startTime As Double, elapsedTime As Double
140     Dim count As Long
141     Dim minMaxValues() As Double ' 新增：用于剪枝的 Min/Max 数组
142 
143     startTime = Timer
144 
145     comboCount = ws.Range("B1").Value
146     low = ws.Range("D1").Value
147     high = ws.Range("F1").Value
148 
149     Dim lastRow As Long
150     lastRow = ws.Cells(ws.Rows.count, "B").End(xlUp).Row
151     data = ws.Range("B3:E" & lastRow).Value
152     Dim dataCount As Long: dataCount = UBound(data, 1)
153 
154     If dataCount < comboCount Then
155         MsgBox "元数据数量不足以组成 " & comboCount & " 组合。", vbCritical
156         Exit Sub
157     End If
158     
159     ' *** 关键新增：计算全局 Min/Max 值用于剪枝 ***
160     minMaxValues = GetMinMaxValues(data)
161 
162     ReDim indices(1 To comboCount)
163 
164     ' 调用优化后的递归函数 (注意：调用时新增了 minMaxValues 参数)
165     RecursiveCombination_Helper data, indices, 1, 0, comboCount, low, high, 0, 0, 0, 0, resultsCollection, minMaxValues
166 
167     ' --- 后续的排序和输出逻辑保持不变 ---
168     count = resultsCollection.count
169     
170     If count > 0 Then
171         ' 将 Collection 转换为 Array 进行排序
172         Dim results() As Variant: ReDim results(1 To count)
173         Dim i As Long: For i = 1 To count: results(i) = resultsCollection.Item(i): Next i
174 
175         If count > 1 Then QuickSort results, 1, count
176         
177         ' 输出结果到工作表 (保持原有输出逻辑)
178         Dim outputRow As Long
179         Dim outputCol As Long
180         outputCol = ws.Cells(1, ws.Columns.count).End(xlToLeft).Column + 2
181         
182         ws.Cells(1, outputCol).Value = "递归" & comboCount & "组合(" & low & "≤X≤" & high & ")结果:" & count
183         ws.Cells(1, outputCol + 1).Value = "火"
184         ws.Cells(1, outputCol + 2).Value = "雷"
185         ws.Cells(1, outputCol + 3).Value = "水"
186         ws.Cells(1, outputCol + 4).Value = "风"
187         ws.Cells(1, outputCol + 5).Value = "平均值"
188 
189         outputRow = 2
190         Dim parts As Variant
191         For i = 1 To count
192             parts = results(i)
193             ws.Cells(outputRow, outputCol).Value = parts(0)
194             ws.Cells(outputRow, outputCol + 1).Value = parts(1)
195             ws.Cells(outputRow, outputCol + 2).Value = parts(2)
196             ws.Cells(outputRow, outputCol + 3).Value = parts(3)
197             ws.Cells(outputRow, outputCol + 4).Value = parts(4)
198             ws.Cells(outputRow, outputCol + 5).Value = parts(5)
199             outputRow = outputRow + 1
200         Next i
201         
202         ' 显示耗时
203         elapsedTime = Timer - startTime
204         
205         ws.Cells(outputRow, outputCol).Value = "元数据:" & dataCount & "条,递归耗时:" & Format(elapsedTime, "0.00") & "秒"
206         
207         MsgBox "元数据: " & dataCount & " 条" & vbCrLf & _
208                "递归 " & comboCount & " 组合(" & low & "≤X≤" & high & ")" & vbCrLf & _
209                "结果: " & count & vbCrLf & _
210                "耗时: " & Format(elapsedTime, "0.00") & " 秒", vbInformation, "计算结果"
211                
212     Else
213         elapsedTime = Timer - startTime
214         MsgBox "未找到符合条件的组合, 耗时:" & Format(elapsedTime, "0.00") & "秒"
215     End If
216 End Sub

 

posted @ 2025-12-14 21:48  易小宝  阅读(3)  评论(0)    收藏  举报