当第一次循环跳出时,怎么goto进入第二次循环?
QQ截图20171205141820.png (29.6 KB, 下载次数: 28)
2017-12-5 14:18 上传
代码如下:
Sub test()
Dim arr, sum, t, i, j, ii
Dim ChaZhi As Single '得分与估分差值
Dim CellSH As Integer '------生成表中输出的首行位置
Dim sumSC As Single '-------输出一组数的 汇总得分 值
Dim CellNum As Integer '--------得分列表 给出的得分个数
Dim NUM As Integer '-----------输出得分值的组数
Dim LoopNum As Integer '-------------跳出死循环判断值
Dim Row, Col, XMNum, QZNum As Integer
NUM = Sheets("sheet1").[k4]
ChaZhi = Sheets("sheet1").[k3]
On Error GoTo errmsg
CellSH = 2
Dim SumTotal(), k(), s()
CellNum = Sheets("sheet1").Range("I1").End(xlDown).Row '--------得分列表 给出的得分个数
XMNum = Sheets("sheet1").Range("A1").End(xlDown).Row '---项目行数
QZNum = Sheets("sheet1").Range("G1").End(xlDown).Row '---权值行数(打分项)
arr = Sheets("sheet1").Range("b2:d" & XMNum)
ReDim SumTotal(CellNum - 2)
ReDim k(QZNum - 2)
ReDim s(QZNum - 2)
For i = 2 To CellNum
SumTotal(i - 2) = Sheets("sheet1").Range("I" & i).Value
Next
For i = 2 To QZNum
k(i - 2) = Sheets("sheet1").Range("G" & i).Value
s(i - 2) = Sheets("sheet1").Range("F" & i).Value
Next
Application.ScreenUpdating = False
'----清除单元格内容,清除标题行颜色
Sheets("生成表").Cells.ClearContents
Sheets("生成表").Cells.Interior.ColorIndex = 0
For CellNum = 0 To UBound(SumTotal)
'------------跳出死循环判断值初始化
LoopNum = 0
With Sheets("生成表")
For ii = 1 To NUM
'防止死循环设置循环测试
Do While LoopNum < 1E+24
sum = 0
'-----------输出项目数(N-1)之和
For i = 1 To UBound(arr, 1) - 1
Randomize
arr(i, 2) = k(Int(Rnd * (UBound(k) + 1)))
sum = sum + arr(i, 1) * arr(i, 2)
Next
'------------t=汇总得分-项目(N-1)的差值
t = SumTotal(CellNum) - sum
'---------比较最后一个数值的差值
If t > 0 Then
For i = 0 To UBound(k)
'--------------该语句同时判断死循环,最后一项的打分项如果没有赋值为数值(还是字母),则是死循环,需跳出到 errmsg(出错语句)
If Abs(t - arr(UBound(arr, 1), 1) * k(i)) <= ChaZhi Then
arr(UBound(arr, 1), 2) = k(i)
sumSC = sum + arr(UBound(arr, 1), 1) * k(i)
Exit Do
End If
Next
End If
LoopNum = LoopNum + 1
Loop
'-------------满足要求的组合赋值给 数组(即 权重、打分项、汇总得分 )
For i = 1 To UBound(arr, 1)
For j = 0 To UBound(k)
If arr(i, 2) = k(j) Then Exit For
Next
arr(i, 3) = arr(i, 1) * arr(i, 2)
arr(i, 2) = s(j)
Next
'--------------结果输出(+4 定义隔几行输出)(cellsh,定义输出首行位置)
.Cells(CellNum * (XMNum + 2) + CellSH - 1, (ii - 1) * 3 + 1).Value = "权重"
.Cells(CellNum * (XMNum + 2) + CellSH - 1, (ii - 1) * 3 + 1).Interior.ColorIndex = 6
.Cells(CellNum * (XMNum + 2) + CellSH - 1, (ii - 1) * 3 + 1).Offset(0, 1) = "打分项"
.Cells(CellNum * (XMNum + 2) + CellSH - 1, (ii - 1) * 3 + 1).Offset(0, 1).Interior.ColorIndex = 6
.Cells(CellNum * (XMNum + 2) + CellSH - 1, (ii - 1) * 3 + 1).Offset(0, 2) = "汇总得分"
.Cells(CellNum * (XMNum + 2) + CellSH - 1, (ii - 1) * 3 + 1).Offset(0, 2).Interior.ColorIndex = 6
.Cells(CellNum * (XMNum + 2) + CellSH, (ii - 1) * 3 + 1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
.Cells(CellNum * (XMNum + 2) + XMNum + CellSH - 1, (ii - 1) * 3 + 3).Value = sumSC
Next
End With
Next
Application.ScreenUpdating = True
' If LoopNum = 100 Then
' MsgBox "自定义差值过小,无满足差值的组合,请增大差值重新计算!"
' Else
' MsgBox "结果为" & NUM & "数据!"
' End If
'
MsgBox "结果为" & NUM & "数据!"
Exit Sub
errmsg:
Application.ScreenUpdating = True
If Not IsNumeric(arr(18, 2)) Then
MsgBox "自定义差值过小,无满足差值的组合,请增大差值重新计算!"
Else
MsgBox "确认一下是否有 生成表工作表?"
End If
End Sub