Help With a Sub

[harber95]

The sub I'm referring to is named Finala() (in Module1 in vba) (start button).
The x and y values are supposed to be between 1 to 10. But it often goes to 11 and even 12.
The sub is supposed to emulate a molecule that moves in an instrument that is 2 dimentional.
When a molecule reaches the edge of the instrument, it's not supposed to pass that point, and move back.
13986

[jonh]

Try this.
(Copy the Clear, Square_Cell, and Sub Table subs back in)


Const NUM_MOLECULES As Byte = 10
Const LIMIT_HIGH = 10
Const LIMIT_LOW = 1
Const NUM_CYCLES As Integer = 20

Dim running As Boolean

Private Type molecule
mvdir As Boolean 'direction
val As Integer
End Type

Dim molecules(1 To 2, 1 To NUM_MOLECULES) As molecule

Sub Finala()
running = Not running
If Not running Then Exit Sub

Erase molecules

Dim s As Integer, i As Integer, j As Integer, cycle As Integer
Dim m As Byte

Clear
Square_Cell
Table

'Sets rows of molecule quantity into excel table
For s = 1 To NUM_MOLECULES
Cells(1, s).Value = s
Next

For cycle = 0 To NUM_CYCLES
For i = LBound(molecules, 1) To UBound(molecules, 1)
For j = LBound(molecules, 2) To UBound(molecules, 2)

m = 1 'Application.WorksheetFunction.RandBetween(0, 1)

Select Case True
Case Not molecules(i, j).mvdir And molecules(i, j).val = 0
'initialise
molecules(i, j).val = Application.WorksheetFunction.RandBetween(LIMIT_LOW, LIMIT_HIGH)
molecules(i, j).mvdir = CBool(Application.WorksheetFunction.RandBetween(0, 1))

Case Not molecules(i, j).mvdir And molecules(i, j).val > LIMIT_LOW
'moving down
molecules(i, j).val = molecules(i, j).val + -m

Case molecules(i, j).mvdir And molecules(i, j).val < LIMIT_HIGH
'moving up
molecules(i, j).val = molecules(i, j).val + m

Case Not molecules(i, j).mvdir And molecules(i, j).val <= LIMIT_LOW
'hit low, start moving up
molecules(i, j).val = LIMIT_LOW + m
molecules(i, j).mvdir = Not molecules(i, j).mvdir

Case molecules(i, j).mvdir And molecules(i, j).val >= LIMIT_HIGH
'hit high, start moving down
molecules(i, j).val = LIMIT_HIGH + -m
molecules(i, j).mvdir = Not molecules(i, j).mvdir

End Select

Cells(i + 1, j) = molecules(i, j).val
Next
DoEvents
Next
If Not running Then Exit Sub

If cycle Then
Cells(3, 12) = "cycle: " & cycle
Else
Cells(3, 12) = "initialising..."
End If
Application.Wait Now() + TimeValue("00:00:01")
Next

End Sub

[harber95]

Thanks a lot!
can you please show me how to turn the cells of the molecules that reached the same coordinate to change its color to blue (referring to the "x", "y" and "number of molecule" cells)? thanks again

[jonh]

Add this


Sub SetCell(i As Integer, j As Integer)
With Cells(i + 1, j)
.Formula = molecules(i, j).val
If molecules(i, j).val = j Then
.Interior.Pattern = xlSolid
.Interior.Color = vbBlue
Else
.Interior.Pattern = xlNone
End If
End With
End Sub

and replace this line


Cells(i + 1, j) = molecules(i, j).val

with


SetCell i, j

[harber95]

It didn't work very well, unfortunately.
The colors appeared randomly when I intended the colors to only appear in cells that has the same x and y values.

[jonh]

It turns blue when the number matches the header.

Upload a picture of what you expect.

[harber95]

14018
Thanks again.

[jonh]

Const NUM_MOLECULES As Byte = 10
Const LIMIT_HIGH = 10
Const LIMIT_LOW = 1
Const NUM_CYCLES As Integer = 20

Dim running As Boolean
Dim cycle As Integer
Dim NoMatchCount As Integer

Private Type molecule
mvdir As Boolean 'direction
val As Integer
matched As Boolean
End Type

Dim molecules(1 To 2, 1 To NUM_MOLECULES) As molecule

Sub Finala()
running = Not running
If Not running Then Exit Sub
Dim i As Integer
resetall
Do Until AllMatched Or NoMatches
Update
If Not running Then Exit Sub
Application.Wait Now() + TimeValue("00:00:01")
DoEvents
Loop
Cells(3, 12) = "no more matches"
running = False
End Sub

Sub Update()
Dim i As Integer, j As Integer, m As Byte
For i = LBound(molecules, 1) To UBound(molecules, 1)
For j = LBound(molecules, 2) To UBound(molecules, 2)
If Not molecules(i, j).matched Then
m = 1
Select Case True
Case cycle = 0
'initialise
molecules(i, j).val = Application.WorksheetFunction.RandBetween(LIMIT_LOW, LIMIT_HIGH)
molecules(i, j).mvdir = CBool(Application.WorksheetFunction.RandBetween(0, 1))

Case Not molecules(i, j).mvdir And molecules(i, j).val > LIMIT_LOW
'moving down
molecules(i, j).val = molecules(i, j).val + -m

Case molecules(i, j).mvdir And molecules(i, j).val < LIMIT_HIGH
'moving up
molecules(i, j).val = molecules(i, j).val + m

Case Not molecules(i, j).mvdir And molecules(i, j).val <= LIMIT_LOW
'hit low, start moving up
molecules(i, j).val = LIMIT_LOW + m
molecules(i, j).mvdir = Not molecules(i, j).mvdir

Case molecules(i, j).mvdir And molecules(i, j).val >= LIMIT_HIGH
'hit high, start moving down
molecules(i, j).val = LIMIT_HIGH + -m
molecules(i, j).mvdir = Not molecules(i, j).mvdir

End Select

Cells(i + 1, j).Formula = molecules(i, j).val
End If
Next
DoEvents
Next

SetCell2

If cycle Then
Cells(3, 12) = "cycle: " & cycle
Else
Cells(3, 12) = "initialising..."
End If
cycle = cycle + 1

End Sub

Private Sub SetCell2()
Dim i As Integer, j As Integer
NoMatchCount = NoMatchCount + 1
For i = LBound(molecules, 2) To UBound(molecules, 2) - 1
If Not molecules(1, i).matched Then
For j = i + 1 To UBound(molecules, 2)
If Not molecules(1, j).matched Then
If molecules(1, i).val = molecules(1, j).val And molecules(2, i).val = molecules(2, j).val Then
hl Range(Cells(2, i), Cells(3, i)), True
molecules(1, i).matched = True
molecules(2, i).matched = True
hl Range(Cells(2, j), Cells(3, j)), True
molecules(1, j).matched = True
molecules(2, j).matched = True
NoMatchCount = 0
Exit For
Else
hl Range(Cells(2, i), Cells(3, i)), False
hl Range(Cells(2, j), Cells(3, j)), False
End If
End If
Next
End If
Next
End Sub

Sub hl(r As Range, b As Boolean)
If b Then
r.Interior.Pattern = xlSolid
r.Interior.Color = vbBlue
Else
r.Interior.Pattern = xlNone
r.Interior.Pattern = xlNone
End If
End Sub

Private Function AllMatched() As Boolean
Dim i As Integer
For i = LBound(molecules, 2) To UBound(molecules, 2)
If Not molecules(1, i).matched Then Exit Function
Next
AllMatched = True
End Function

Private Function NoMatches()
NoMatches = NoMatchCount > ((LIMIT_HIGH - LIMIT_LOW) * 2)
End Function

Sub resetall()
NoMatchCount = 0
Erase molecules
Clear
Square_Cell
Table
cycle = 0
Dim i As Integer
For i = 1 To NUM_MOLECULES
Cells(1, i).Value = i
Next
End Sub

[harber95]

I appreciate your effort, but some lines are errors:

1. The sub named resetall() have the line "erase molecules" as a type mismatch.
2. The Const are referred to as compile error (it joins with another sub. changing the order won't help)

I'll send you the code I copied. 14021

[jonh]

I can't view the file at the moment.
You should only need to replace all of the code and copy the other 3 subs back in as before.
erase molecules isn't a new line.

[harber95]

That's what I did. I even tried to change the order of the subs. Maybe there is another way to put the subs together. Anyways, thanks for the help, I hope to hear from you soon.

[jonh]

Move the clear, square_cell and table subs to the bottom of the module, or put them in a new module (insert > module) so they're out of the way.

I updated Clear and Square


Sub Clear()
Range("A1:J3").ClearContents
End Sub

Sub Square_Cell() 'makes cells in square shape
Columns("A:fxd").ColumnWidth = 2
Rows("1:250").RowHeight = 15
Columns("K:L").ColumnWidth = 20
Columns("K").HorizontalAlignment = xlRight
End Sub

[harber95]

Works smoothly. Thanks a lot