Увеличил случайный поиск при определении лучшей строки.
| Код |
|---|
Option Explicit
Private aSour As Variant
Private aIndx As Variant
Private aComb As Variant
Private dic As Dictionary
Private Sub CommandButton2_Click()
Unload Me
End Sub
Private Sub TextBox1_Change()
ChangeAddress
End Sub
Private Sub TextBox2_Change()
ChangeAddress
End Sub
Private Sub TextBox4_Change()
ChangeAddress
End Sub
Private Sub ChangeAddress()
Dim rSour As Range
On Error Resume Next
Set rSour = Лист1.Range(Me.TextBox4.Value).Resize(TextBox2.Value, TextBox1.Value)
If Err = 0 Then
LabelAddress.Caption = rSour.Address(0, 0, xlA1)
aSour = rSour.Value
aSour = TransformSourceArray(aSour)
End If
On Error GoTo 0
End Sub
Private Function TransformSourceArray(aSour As Variant) As Variant
Dim arr As Variant, brr As Variant
ReDim arr(LBound(aSour, 1) To UBound(aSour, 1))
ReDim brr(LBound(aSour, 2) To UBound(aSour, 2)) As Boolean
Dim ya As Long, xa As Long
For ya = LBound(arr) To UBound(arr)
For xa = LBound(brr) To UBound(brr)
brr(xa) = aSour(ya, xa) = 1
Next
arr(ya) = brr
Next
TransformSourceArray = arr
End Function
Private Sub TextBox5_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
If Not IsDate(TextBox5.Value) Then
TextBox5.Value = "0:01:00"
Cancel = True
End If
End Sub
Private Sub TextBox5_Change()
ThisWorkbook.Names("остановка_через").RefersToRange.Value = TextBox5.Text
End Sub
Private Sub UserForm_Initialize()
Randomize
TextBox5.Text = ThisWorkbook.Names("остановка_через").RefersToRange.Text
ChangeAddress
End Sub
Private Sub CommandButton1_Click()
Static dtExit As Date
On Error Resume Next
Application.OnTime EarliestTime:=dtExit, Procedure:="SetExitFlag", Schedule:=False
On Error GoTo 0
dtExit = Now + CDate(TextBox5.Text)
exitFlag = False
Application.OnTime dtExit, "SetExitFlag"
Application.StatusBar = "Следующая остановка после " & Format(dtExit, "hh:mm:ss")
Me.Hide
Me.TextBox1.Enabled = False
Me.TextBox2.Enabled = False
Me.TextBox3.Enabled = False
Me.TextBox4.Enabled = False
If dic Is Nothing Then
Set dic = New Dictionary
ReDim aComb(1 To UBound(aSour(1)))
' Лист2.Cells.ClearContents
Лист2.Select
End If
FindBestСombination
Application.StatusBar = False
End Sub
Private Sub FindBestСombination()
Do
VaryComb
If exitFlag Then
Exit Do
End If
DoEvents
Loop
PrintResult aComb
Me.Show
End Sub
Private Sub VaryComb()
Dim cmpRow As Variant
Dim optRow As Variant
Dim optRows As Variant
Dim cIndx As Variant
'Dim sDone As String
Dim aDone As Variant
ReDim aDone(1 To UBound(aSour)) As Boolean
Dim yf As Long, yo As Long, ySour As Long, nComb As Long
For yf = 1 To UBound(aSour(1))
optRows = GetOptRows(cmpRow)
AddRndRow optRows
yo = Rnd() * UBound(optRows)
ySour = optRows(yo)
' ySour = Int(Rnd() * UBound(aSour)) + 1
optRow = aSour(ySour)
cmpRow = SumRows(optRow, cmpRow)
aDone(ySour) = True
cIndx = GetIndxArray(aDone)
nComb = UBound(cIndx)
GetUniqCountAndAddDic cIndx, nComb
'Debug.Print yf, ySour, UniqCount(cmpRow), nComb ', sDone
DoEvents
Next
End Sub
Private Sub AddRndRow(optRows As Variant)
ReDim Preserve optRows(LBound(optRows) To UBound(optRows) + 1)
optRows(UBound(optRows)) = Int(Rnd() * UBound(aSour)) + 1
End Sub
Private Function GetIndxArray(aDone As Variant) As Variant
Dim va As Variant, ya As Long
For Each va In aDone
If va Then ya = ya + 1
Next
If ya > 0 Then
Dim arr As Variant, yDone As Long
ReDim arr(1 To ya)
ya = LBound(arr)
yDone = LBound(aDone)
For Each va In aDone
If va Then
arr(ya) = yDone
ya = ya + 1
End If
yDone = yDone + 1
Next
GetIndxArray = arr
End If
End Function
Private Function GetOptRows(cmpRow As Variant) As Variant
Dim ya As Long, curCount As Long, optCount As Long, optRows As String, sumRow As Variant
For ya = 1 To UBound(aSour)
sumRow = SumRows(aSour(ya), cmpRow)
curCount = UniqCount(sumRow)
If optCount < curCount Then
optCount = curCount
optRows = ya
ElseIf curCount = optCount Then
optRows = optRows & " " & ya
End If
Next
GetOptRows = Split(optRows, " ")
End Function
' Do
' aIndx_Init
' GetUniqCountAndAddDic aIndx
'
'
' If exitFlag Then
' Exit Do
' End If
' DoEvents
' Loop
' PrintResult aComb
' Me.Show
Private Function SumRows(arr As Variant, brr As Variant) As Variant
If IsEmpty(brr) Then
SumRows = arr
Exit Function
ElseIf IsEmpty(arr) Then
SumRows = brr
Exit Function
End If
Dim crr As Variant, ya As Long
ReDim crr(LBound(arr) To UBound(arr)) As Boolean
For ya = LBound(arr) To UBound(arr)
crr(ya) = arr(ya) Or brr(ya)
Next
SumRows = crr
End Function
Private Function UniqCount(arr As Variant) As Long
Dim va As Variant
For Each va In arr
If va Then UniqCount = UniqCount + 1
Next
End Function
Private Function GetUniqCountAndAddDic(cIndx As Variant, nComb As Long) As Long
Dim sIndx As String
sIndx = Join(cIndx, " ")
If dic.Exists(sIndx) Then
GetUniqCountAndAddDic = dic(sIndx)
Exit Function
End If
Dim curUniqCount As Long
curUniqCount = CountUniq(cIndx, aSour)
Dim combItem As Variant
If IsEmpty(aComb(nComb)) Then
ReDim combItem(1 To UBound(aSour(1)))
aComb(nComb) = combItem
combItem = Empty
End If
If IsEmpty(aComb(nComb)(curUniqCount)) Then
ReDim combItem(1 To 1)
Else
combItem = aComb(nComb)(curUniqCount)
ReDim Preserve combItem(1 To UBound(combItem) + 1)
End If
combItem(UBound(combItem)) = cIndx
aComb(nComb)(curUniqCount) = combItem
dic(sIndx) = curUniqCount
GetUniqCountAndAddDic = curUniqCount
End Function
Private Sub aIndx_Init()
If IsEmpty(aIndx) Then
ReDim aIndx(1 To 1)
End If
Dim xa As Long
For xa = LBound(aIndx) To UBound(aIndx)
aIndx(xa) = xa
Next
End Sub
Private Function CountUniq(aIndx As Variant, aSour As Variant) As Long
Dim iInd As Long, iCount As Long, xs As Long, ys As Long
Dim aDone As Variant
ReDim aDone(1 To UBound(aSour(1))) As Boolean
For iInd = LBound(aIndx) To UBound(aIndx)
ys = aIndx(iInd)
If ys <= UBound(aSour) Then
For xs = 1 To UBound(aSour(ys))
If aSour(ys)(xs) Then
If Not aDone(xs) Then
aDone(xs) = True
iCount = iCount + 1
End If
End If
Next
End If
Next
CountUniq = iCount
End Function
Private Sub PrintResult(aComb As Variant)
Dim rTarget As Range
Set rTarget = Лист2.Cells(1, 1)
rTarget.Parent.UsedRange.ClearContents
Dim yc As Long, xt As Long
xt = 1
For yc = UBound(aComb) To LBound(aComb) Step -1
If Not IsEmpty(aComb(yc)) Then
Set rTarget = Лист2.Cells(2, xt)
rTarget.Cells(0, 1).Resize(1, 2).Value = Array("Комбинаций", yc)
PrintResultOneCombo aComb(yc), rTarget
xt = xt + 3
End If
Next
rTarget.Parent.Parent.Saved = True
End Sub
Private Sub PrintResultOneCombo(aComb, rTarget As Range)
rTarget.Cells(1, 1).Resize(1, 3).Value = Array("Уникальных", "Коробки", Empty)
Set rTarget = rTarget.Cells(2, 1)
Dim yc As Long, yb As Long, arr As Variant, hrr As Variant, brr As Variant
For yc = UBound(aComb) To LBound(aComb) Step -1
If Not IsEmpty(aComb(yc)) Then
arr = aComb(yc)
ReDim brr(1 To UBound(arr), 1 To 2)
If rTarget.Row + UBound(brr, 1) > rTarget.Parent.Rows.Count Then
Set rTarget = rTarget.Cells(1, UBound(brr, 2) + 2).EntireColumn.Cells(1, 1)
If rTarget.Row + UBound(brr, 1) > rTarget.Parent.Rows.Count Then
Exit For
End If
End If
For yb = LBound(arr) To UBound(arr)
brr(yb, 1) = yc
brr(yb, 2) = Join(arr(yb), ", ")
Next
Set rTarget = rTarget.Cells(1, 1).Resize(UBound(brr, 1), UBound(brr, 2))
rTarget.Value = brr
Set rTarget = rTarget.Cells(rTarget.Rows.Count + 2, 1)
End If
Next
End Sub
|
