Sub random_insertion()
'main variables
Dim start_row As Long, start_col As Long, my_rows As Long, my_cols As Long, required As Long
' helper variables
Dim i As Long, j As Long, counter As Long, tmp_rng As Range
' define random fill location
If Selection.Cells.Count < 2 Then
MsgBox "Please select whole range to be filled before running macro", vbCritical, "! Please select proper range !"
Exit Sub
End If
start_col = Selection.Column
start_row = Selection.Row
my_cols = Selection.Columns.Count
my_rows = Selection.rows.Count
' check initial setup
required = Cells(my_rows + 2 + start_row, my_cols + start_col) - Cells(my_rows + 2 + start_row, my_cols + start_col + 1)
If required <> Cells(my_rows + start_row, my_cols + 2 + start_col) - Cells(my_rows + start_row + 1, my_cols + 2 + start_col) Then
MsgBox "Sorry, cant do that, as required rows sums is different than columns sum", vbCritical, "! Please correct data !"
Exit Sub
End If
' no clearing working space, just change pre-inserted 1's
For i = 0 To my_rows - 1
For j = 0 To my_cols - 1
If Cells(i + start_row, j + start_row) = 1 Then Cells(i + start_row, j + start_row) = "x"
Next j, i
'initial random assignment
counter = 0
Randomize
While counter < required
i = WorksheetFunction.RandBetween(0, my_rows - 1)
j = WorksheetFunction.RandBetween(0, my_cols - 1)
If Cells(i + start_row, j + start_col) = "" Then
Cells(i + start_row, j + start_col) = 1
counter = counter + 1
End If
Wend
optimization start_row, start_col, my_rows, my_cols
End Sub
Private Sub optimization(start_row As Long, start_col As Long, my_rows As Long, my_cols As Long)
Dim i As Long, j As Long, x As Long, y As Long, counter As Long, sq_sum As Long, tmp As Variant, swaps As Long
' initialize
Randomize
counter = 0
swaps = 0
sq_sum = Cells(my_rows + 3 + start_row, my_cols + 3 + start_col)
' loop trying to swap empty cells and 1's
Application.ScreenUpdating = False
While sq_sum > 0 And counter < 25000 'counter limit may be increased or replaced with time limit
i = WorksheetFunction.RandBetween(0, my_rows - 1)
j = WorksheetFunction.RandBetween(0, my_cols - 1)
y = WorksheetFunction.RandBetween(0, my_rows - 1)
x = WorksheetFunction.RandBetween(0, my_cols - 1)
If Cells(i + start_row, j + start_col).Text <> "0" And Cells(y + start_row, x + start_col).Text <> "0" _
And Cells(i + start_row, j + start_col).Text <> "x" And Cells(y + start_row, x + start_col).Text <> "x" Then
If Cells(i + start_row, j + start_col) <> Cells(y + start_row, x + start_col) Then
tmp = Cells(i + start_row, j + start_col)
Cells(i + start_row, j + start_col) = Cells(y + start_row, x + start_col)
Cells(y + start_row, x + start_col) = tmp
If Cells(my_rows + 3 + start_row, my_cols + 3 + start_col) <= sq_sum Then
sq_sum = Cells(my_rows + 3 + start_row, my_cols + 3 + start_col)
swaps = swaps + 1
Else
tmp = Cells(i + start_row, j + start_col)
Cells(i + start_row, j + start_col) = Cells(y + start_row, x + start_col)
Cells(y + start_row, x + start_col) = tmp
End If
End If
End If
counter = counter + 1
If counter Mod 100 = 0 Or sq_sum = 0 Then 'show progress each 100 rounds in status bar
Application.StatusBar = counter & " attempts and " & swaps & " swaps done so far, result = " & sq_sum
End If
Wend
Application.ScreenUpdating = True
tmp = " after: " & counter & " attempts and " & swaps & " swaps."
If sq_sum = 0 Then
MsgBox "Fisished" & tmp, vbInformation
Else
If MsgBox("Stopped with not final fit achieved" & tmp & vbLf & vbLf & "Shall I continue with the same initial values?", _
vbCritical + vbYesNo) = vbYes Then optimization start_row, start_col, my_rows, my_cols
End If
For i = 0 To my_rows - 1
For j = 0 To my_cols - 1
If Cells(i + start_row, j + start_row) = "x" Then Cells(i + start_row, j + start_row) = 1
Next j, i
Application.StatusBar = ""
End Sub
