For a computer science homework, with the example of money, I need to print all possible combination of numbers that add up to 15. I have 9 coins of 1GBP, 3 coins of 2GBP and 3 banknotes of 5GBP. The code below does all possible combinations but I only need to print ones where the numbers add up to 15.
Here is the code below.
Dim num(15) As Integer
Dim a%, b%, c%, d%, e%, f%, g%, h%, i%, j%, k%, l%, m%, n%, o%
num(1) = 1
num(2) = 1
num(3) = 1
num(4) = 1
num(5) = 1
num(6) = 1
num(7) = 1
num(8) = 1
num(9) = 1
num(10) = 2
num(11) = 2
num(12) = 2
num(13) = 5
num(14) = 5
num(15) = 5
Dim count As Integer
For a = 0 To 14
For b = 0 To 14
For c = 0 To 14
For d = 0 To 14
For e = 0 To 14
For f = 0 To 14
For g = 0 To 14
For h = 0 To 14
For i = 0 To 14
For j = 0 To 14
For k = 0 To 14
For l = 0 To 14
For m = 0 To 14
For n = 0 To 14
For o = 0 To 14
Console.WriteLine(num(a) & num(b) & num(c) & num(d) & num(e) & num(f) & num(g) & num(h) & num(i) & num(j) & num(k) & num(l) & num(m) & num(n) & num(o))
count += 1
Next o
Next n
Next m
Next l
Next k
Next j
Next i
Next h
Next g
Next f
Next e
Next d
Next c
Next b
Next a
My recursive isn't that good I had to add a list which contains all failed paths to exit other recursive paths quickly, could probably do it without that if it was smarter.
Anyways what I'm trying to do is every time a duplicate is detected it either drops to the next row or goes all the way to the top and tries to fill in the duplicate value only if its possible to keep the values unique. Then I get a bunch of rows all uniquely sorted. Now I coded all this properly and it works just fine.. the problem is undoing this to get back the same solution, there could be multiple answers I want to be able to list all the possible answers which are the same length as the input list.
If the bitstream contains like 2 zero's and when decoding this it can't insert 2 unique values in the row as some value is already previously used then the whole current node gets skipped as being the wrong answer.
Say I got this number
1 9 4 2 4 2 4 2 1 2 4 3 2 4 1 2 3 4 0 3 1 3 0 4 2 0 4 1 0 0 2 0 4 6 3 1 3
The Bits are 0 for unique and 1 for duplicate
0 0 0 0 1 0 1 0 0 1 0 0 1 0 0 1 0 0 0 1 1 0 0 1 0 0 1 0 0 1 1 1 1 0 0 0 1
The rows look like this
(Row 0): 1 9 4 2 3 0
(Row 1): 4 2 1 3 0
(Row 2): 4 2 1 0 3
(Row 3): 2 4 3
(Row 4): 2 4 1
(Row 5): 2 3 4 0
(Row 6): 4 2 0
(Row 7): 4 1 0 2
(Row 8): 4 6 3 1
All the rows combined into a single string for passing it to program
1 9 4 2 3 0 4 2 1 3 0 4 2 1 0 3 2 4 3 2 4 1 2 3 4 0 4 2 0 4 1 0 2 4 6 3 1
I run this function by pressing Button2
3 textbox's
txtUndoPlaintext.Text = "1 9 4 2 3 0 4 2 1 3 0 4 2 1 0 3 2 4 3 2 4 1 2 3 4 0 4 2 0 4 1 0 2 4 6 3 1"
txtUndoBitMask.Text = "0 0 0 0 1 0 1 0 0 1 0 0 1 0 0 1 0 0 0 1 1 0 0 1 0 0 1 0 0 1 1 1 1 0 0 0 1"
txtOutput (this one is multi-line) where the answers print out.
The answer I get back is
1 9 4 2 4 2 4 2 1 2 4 3 2 4 1 2 3 4 0 3 1 3 0 4 2 0 4 1 0 0 2 0 4 6 3 1 3
which checking with the original is off where its 0 2 to 2 0 on index 30
1 9 4 2 4 2 4 2 1 2 4 3 2 4 1 2 3 4 0 3 1 3 0 4 2 0 4 1 0 0 0 2 4 6 3 1 3
My problem is I only get back one answer how do I get all answers back?
Here is my code
Public bitmask() As Byte
Public FailedPaths As New List(Of String)
Public Uniques()() As Byte
Public Function GetUniquesAt(uniques()() As Byte, CurrentRow As UInteger, ProcessedBits()() As Byte) As Byte()
Dim eachUniqueIndex As Integer = 0
Dim UniquesUsed() As Byte
'ReDim UniquesUsed(0)
For eachUniqueIndex = 0 To UBound(uniques(CurrentRow), 1)
If ProcessedBits(CurrentRow)(eachUniqueIndex) = 1 Then
'Add a new number to this row
If UniquesUsed Is Nothing Then
ReDim Preserve UniquesUsed(0)
Else
ReDim Preserve UniquesUsed(UniquesUsed.Length)
End If
Dim LastValueInRow As Integer = UniquesUsed.Length
UniquesUsed(LastValueInRow - 1) = uniques(CurrentRow)(eachUniqueIndex)
End If
Next
Return UniquesUsed
End Function
Public Function GetCurrentOffsetForRow(uniques()() As Byte, CurrentRow As UInteger, ProcessedBits()() As Byte) As UInteger
Dim eachUniqueIndex As Integer = 0
For eachUniqueIndex = 0 To UBound(uniques(CurrentRow), 1)
If ProcessedBits(CurrentRow)(eachUniqueIndex) = 0 Then
Return eachUniqueIndex
End If
Next
Return eachUniqueIndex
End Function
Private Sub Button2_Click(sender As Object, e As EventArgs) Handles Button2.Click
txtUndoPlaintext.Text = Replace(txtUndoPlaintext.Text, " ", " ")
txtUndoPlaintext.Text = txtUndoPlaintext.Text.TrimStart(CChar(" "))
txtUndoPlaintext.Text = txtUndoPlaintext.Text.TrimEnd(CChar(" "))
Dim UniqueList() As Byte = Split(txtUndoPlaintext.Text, " ").[Select](Function(n) Byte.Parse(n)).ToArray()
txtUndoBitMask.Text = Replace(txtUndoBitMask.Text, " ", " ")
txtUndoBitMask.Text = txtUndoBitMask.Text.TrimStart(CChar(" "))
txtUndoBitMask.Text = txtUndoBitMask.Text.TrimEnd(CChar(" "))
bitmask = Split(txtUndoBitMask.Text, " ").[Select](Function(n) Byte.Parse(n)).ToArray()
'Clear uniques from previous runs.
Uniques = Nothing
Dim PreviousRow As UInteger = 0
'Check if unique exists from first row to current row
Dim CurrentRow As UInteger = 0
Dim ContainsValueInRow As Boolean = False
'if uniques current row isn't initialized then initialize it.
If Uniques Is Nothing Then
ReDim Uniques(CurrentRow)
Uniques(CurrentRow) = New Byte() {}
End If
Dim ProcessedBits()() As Byte
ReDim ProcessedBits(CurrentRow)
ProcessedBits(CurrentRow) = New Byte() {}
'Load uniques up in the Uniques List
For Each Value In UniqueList
ContainsValueInRow = False
'Check row if it contains the current Value if it does change to next row.
For eachUniqueIndex = 0 To UBound(Uniques(CurrentRow), 1)
If Uniques(CurrentRow)(eachUniqueIndex) = Value Then
ContainsValueInRow = True
Exit For
End If
Next
If ContainsValueInRow Then
CurrentRow += 1
ReDim Preserve Uniques(CurrentRow)
Uniques(CurrentRow) = New Byte() {}
ReDim Preserve ProcessedBits(CurrentRow)
ProcessedBits(CurrentRow) = New Byte() {}
End If
Dim LastValueInRow As Integer = Uniques(CurrentRow).Length
'Add new number to this row
ReDim Preserve Uniques(CurrentRow)(LastValueInRow)
Uniques(CurrentRow)(LastValueInRow) = Value
ReDim Preserve ProcessedBits(CurrentRow)(LastValueInRow)
ProcessedBits(CurrentRow)(LastValueInRow) = 0
Next
FailedPaths.Clear()
CurrentRow = 0
Dim CurrentProcessedByte As Long = 0
Dim CurrentOffset As Long = 0
Dim FinalString As String = ""
Dim ExitedTooSoon As Boolean = False
ProcessTreeNodes(FinalString, ProcessedBits, CurrentProcessedByte, PreviousRow, CurrentRow)
Dim output As String
output = output & "Final Decoded Answer: " & FinalString & vbCrLf
output = output & "Stopped at row: " & CurrentRow & vbCrLf
txtOutput.Text = txtOutput.Text & output
End Sub
Public Sub ProcessTreeNodes(_FinalString As String, _ProcessedBits()() As Byte, CurrentProcessedByte As Byte, PreviousRow As UInteger, CurrentRow As UInteger)
'Clone Data to get rid of References, so we always copy here
Dim ProcessedBits(_ProcessedBits.GetUpperBound(0))() As Byte
For i = 0 To _ProcessedBits.Length - 1
ProcessedBits(i) = _ProcessedBits(i).Clone()
Next
Dim FinalString As String = _FinalString.Clone()
Dim LoopTwo As Boolean = False
Dim ExitedTooSoon As Boolean = False
Dim CurrentOffset As UInteger = GetCurrentOffsetForRow(Uniques, CurrentRow, ProcessedBits)
While True
'If finished with everything just simply exit this loop
If bitmask.Length = CurrentProcessedByte Then Exit While
'Unique currently on this row no need any extra processing
If bitmask(CurrentProcessedByte) = 0 Then
'Bad Sub Node.. exit it
If Uniques(CurrentRow).Length = CurrentOffset Then
ExitedTooSoon = True
Exit While
End If
FinalString = FinalString & " " & Uniques(CurrentRow)(CurrentOffset)
'Mark as processed for future calculations
ProcessedBits(CurrentRow)(CurrentOffset) = 1
End If
'Switch to a new row
If bitmask(CurrentProcessedByte) = 1 Then
CurrentOffset = 0
PreviousRow = CurrentRow
'If Blank Row -> Build a next Row Or Start from Top.
'If the row is Row 0, then next row is Row 1, but if Row 1.. then next row to check is Row 0 etc..
If CurrentRow = 0 Then
CurrentRow = 1
ElseIf CurrentRow > 0 Then
CurrentRow = 0
End If
Dim MainRowUniquesUsed() As Byte
Dim CurrentRowUniques() As Byte
'Do crazy loop checks to see whats the next value.
While True
If FailedPaths.Contains(FinalString) Then
ExitedTooSoon = True
Exit While
End If
MainRowUniquesUsed = GetUniquesAt(Uniques, PreviousRow, ProcessedBits)
CurrentRowUniques = GetUniquesAt(Uniques, CurrentRow, ProcessedBits)
CurrentOffset = GetCurrentOffsetForRow(Uniques, CurrentRow, ProcessedBits)
If LoopTwo Then
'Get a list of all Rows used +1
Dim listsOfUniquesUsed As New List(Of Byte())
Dim LastRow As Long = 0
Dim IsPossible As Boolean = True
For row As Long = 0 To ProcessedBits.Length - 1
'Get a list of every value used in every row
'Don't process the tree until at least 2 rows are used.. then it will use the 3rd row if possible
If ProcessedBits.Length > 1 AndAlso ProcessedBits(1)(0) = 0 Then
Exit For
End If
If ProcessedBits(row)(0) = 1 Then
listsOfUniquesUsed.Add(GetUniquesAt(Uniques, row, ProcessedBits))
'Get the first value of a un-used Row just to checking if it's a possible answer too.
ElseIf ProcessedBits(row)(0) = 0 Then
listsOfUniquesUsed.Add(New Byte() {Uniques(row)(0)})
LastRow = row
Exit For
End If
'Hit last row and last row is already used so this whole thing is not possible
If row = ProcessedBits.Length - 1 AndAlso ProcessedBits(row)(0) = 1 Then
IsPossible = False
End If
Next
If IsPossible Then
'This checks to make sure all the commons that are partially in all lists.
Dim list() As Byte = listsOfUniquesUsed.SelectMany(Function(x) x).Distinct().Where(Function(item) listsOfUniquesUsed.All(Function(l) l.Contains(item))).ToArray()
'If a possible match is found
'make sure there Is a row below the current row, If no point in doing it.
'If list.Count > 0 AndAlso PreviousRow + 1 < Uniques.Length AndAlso FailedPaths.Where(Function(c) c.StartsWith(FinalString)).Count = 0 Then
If list.Count > 0 AndAlso PreviousRow + 1 < Uniques.Length AndAlso Not FailedPaths.Contains(FinalString) Then
'CurrentOffset Spoofed
Dim PreviousRowSpoofed As UInteger = CurrentRow
Dim CurrentRowSpoofed As UInteger = LastRow
'Possible 2 answers are possible!
ProcessTreeNodes(FinalString, ProcessedBits, CurrentProcessedByte, PreviousRowSpoofed, CurrentRowSpoofed)
End If
End If
End If
'Quick fix
If MainRowUniquesUsed Is Nothing Then
CurrentRow = PreviousRow
CurrentOffset = GetCurrentOffsetForRow(Uniques, CurrentRow, ProcessedBits)
FinalString = FinalString & " " & Uniques(CurrentRow)(CurrentOffset)
'Mark as processed for future calculations
ProcessedBits(CurrentRow)(CurrentOffset) = 1
LoopTwo = True
Exit While
End If
'Next Row is blank, then its just a fresh entry
If CurrentRowUniques Is Nothing Then
FinalString = FinalString & " " & Uniques(CurrentRow)(CurrentOffset)
'Mark as processed for future calculations
ProcessedBits(CurrentRow)(CurrentOffset) = 1
LoopTwo = True
Exit While
'Scan this row if its a possible insert here or possible go to next
ElseIf CurrentRowUniques IsNot Nothing Then
Dim ValueNotUsed() As Byte = Uniques(CurrentRow) _
.Select(Function(item, index) New With {.Item = item, .Index = index}) _
.Where(Function(x) ProcessedBits(CurrentRow)(x.Index) = 0) _
.Select(Function(x) x.Item).ToArray()
'If no values are possible, then go check next row.
If ValueNotUsed.Length = 0 Then
'If the Next Row is the Row we were in, just before this one Jump 2 rows
If CurrentRow + 1 = PreviousRow Then
CurrentRow = CurrentRow + 2
Else
CurrentRow = CurrentRow + 1
End If
'This quick fix isn't checked could be wrong
'it just starts from the top if it hit a row past the last row.
If CurrentRow >= Uniques.Length Then
CurrentRow = 0
End If
Continue While
'This is a possible answer area (where it would spawn multiple nodes to keep recursively finishing it.)
ElseIf ValueNotUsed.Length > 0 Then
If Not MainRowUniquesUsed.Contains(ValueNotUsed(0)) Then
'The next pattern isn't found in this Row, so we hope next row.
'Keep hopping rows until we hit the row which is the farthest one
'Then we could exit out.
'If the Next Row is the Row we were in, just before this one Jump 2 rows
If CurrentRow + 1 = PreviousRow Then
CurrentRow = CurrentRow + 2
Else
CurrentRow = CurrentRow + 1
End If
If CurrentRow + 1 > PreviousRow Then
'Hit the row we currently on and still no match so its a bad loop
ExitedTooSoon = True
Exit While
ElseIf CurrentRow >= Uniques.Length Then
'Probably does not work?
CurrentRow = 0
End If
Continue While
End If
'Scan Previous Rows for the same answer as in this Row.
FinalString = FinalString & " " & Uniques(CurrentRow)(CurrentOffset)
'Mark as processed for future calculations
ProcessedBits(CurrentRow)(CurrentOffset) = 1
LoopTwo = True
Exit While
End If
End If
End While
End If
If ExitedTooSoon Then
Exit While
End If
CurrentOffset += 1
CurrentProcessedByte += 1
End While
If ExitedTooSoon Then
FailedPaths.Add(FinalString)
Exit Sub
End If
Dim output As String
output = output & "TreeNode Decoded Answer: " & FinalString & vbCrLf
output = output & "Stopped at row: " & CurrentRow & vbCrLf
txtOutput.Text = txtOutput.Text & output
End Sub
If you need the value generator here it is I made and I have no problem with it.
(can't post it in this question as it exceeds the size limit)
https://pastebin.com/raw/0y2DnRhi
Actually, It gets all the answers (I Hope) at least it gets the right answer and the second right answer I found with the previous code.
But some answers it finds are not even right, so it's not really a good answer. Here is the code anyways anyone wishes to modify it to work better please go ahead.
Original Answer:
1 9 4 2 4 2 4 2 1 2 4 3 2 4 1 2 3 4 0 3 1 3 0 4 2 0 4 1 0 0 2 0 4 6 3 1 3
Finds these correct answers
1 9 4 2 4 2 4 2 1 2 4 3 2 4 1 2 3 4 0 3 1 3 0 4 2 0 4 1 0 0 0 2 4 6 3 1 3
1 9 4 2 4 2 4 2 1 2 4 3 2 4 1 2 3 4 0 3 1 3 0 4 2 0 4 1 0 0 2 0 4 6 3 1 3
1 9 4 2 4 2 4 2 1 2 4 3 2 4 1 2 3 4 0 3 1 3 0 4 2 0 4 1 0 2 0 0 4 6 3 1 3
1 9 4 2 4 2 4 2 1 2 4 3 2 4 1 2 3 4 0 3 4 2 0 4 1 0 1 3 0 0 0 2 4 6 3 1 3
1 9 4 2 4 2 4 2 1 2 4 3 2 4 1 2 3 4 0 3 4 2 0 4 1 0 1 3 0 0 2 0 4 6 3 1 3
1 9 4 2 4 2 4 2 1 2 4 3 2 4 1 2 3 4 0 3 4 2 0 4 1 0 1 3 0 2 0 0 4 6 3 1 3
Finds these wrong answers too
1 9 4 2 4 2 4 2 1 2 4 3 2 4 1 2 3 4 0 3 4 2 0 1 3 0 4 1 0 0 0 2 4 6 3 1 3
1 9 4 2 4 2 4 2 1 2 4 3 2 4 1 2 3 4 0 3 4 2 0 1 3 0 4 1 0 0 2 0 4 6 3 1 3
1 9 4 2 4 2 4 2 1 2 4 3 2 4 1 2 3 4 0 3 4 2 0 1 3 0 4 1 0 2 0 0 4 6 3 1 3
I guess the wrong answers could also be possible in some way.. so I guess there is no way to avoid it.
'New algorithm
Private Sub Button5_Click(sender As Object, e As EventArgs) Handles Button5.Click
txtUndoPlaintext.Text = Replace(txtUndoPlaintext.Text, " ", " ")
txtUndoPlaintext.Text = txtUndoPlaintext.Text.TrimStart(CChar(" "))
txtUndoPlaintext.Text = txtUndoPlaintext.Text.TrimEnd(CChar(" "))
Dim UniqueList() As Byte = Split(txtUndoPlaintext.Text, " ").[Select](Function(n) Byte.Parse(n)).ToArray()
txtUndoBitMask.Text = Replace(txtUndoBitMask.Text, " ", " ")
txtUndoBitMask.Text = txtUndoBitMask.Text.TrimStart(CChar(" "))
txtUndoBitMask.Text = txtUndoBitMask.Text.TrimEnd(CChar(" "))
bitmask = Split(txtUndoBitMask.Text, " ").[Select](Function(n) Byte.Parse(n)).ToArray()
'Clear uniques from previous runs.
Uniques = Nothing
Dim PreviousRow As UInteger = 0
'Check if unique exists from first row to current row
Dim CurrentRow As UInteger = 0
Dim ContainsValueInRow As Boolean = False
'if uniques current row isn't initialized then initialize it.
If Uniques Is Nothing Then
ReDim Uniques(CurrentRow)
Uniques(CurrentRow) = New Byte() {}
End If
Dim ProcessedBits()() As Byte
ReDim ProcessedBits(CurrentRow)
ProcessedBits(CurrentRow) = New Byte() {}
'Load uniques up in the Uniques List
For Each Value In UniqueList
ContainsValueInRow = False
'Check row if it contains the current Value if it does change to next row.
For eachUniqueIndex = 0 To UBound(Uniques(CurrentRow), 1)
If Uniques(CurrentRow)(eachUniqueIndex) = Value Then
ContainsValueInRow = True
Exit For
End If
Next
If ContainsValueInRow Then
CurrentRow += 1
ReDim Preserve Uniques(CurrentRow)
Uniques(CurrentRow) = New Byte() {}
ReDim Preserve ProcessedBits(CurrentRow)
ProcessedBits(CurrentRow) = New Byte() {}
End If
Dim LastValueInRow As Integer = Uniques(CurrentRow).Length
'Add new number to this row
ReDim Preserve Uniques(CurrentRow)(LastValueInRow)
Uniques(CurrentRow)(LastValueInRow) = Value
ReDim Preserve ProcessedBits(CurrentRow)(LastValueInRow)
ProcessedBits(CurrentRow)(LastValueInRow) = 0
Next
FailedPaths.Clear()
CurrentRow = 0
Dim CurrentProcessedByte As Long = 0
Dim CurrentOffset As Long = 0
Dim FinalString As String = ""
Dim ExitedTooSoon As Boolean = False
Process(FinalString, ProcessedBits, CurrentProcessedByte, PreviousRow, CurrentRow)
Dim output As String
output = output & "Final Decoded Answer: " & FinalString & vbCrLf
output = output & "Stopped at row: " & CurrentRow & vbCrLf
txtOutput.Text = txtOutput.Text & output
End Sub
Public Sub Process(_FinalString As String, _ProcessedBits()() As Byte, CurrentProcessedByte As Byte, PreviousRow As UInteger, CurrentRow As UInteger)
'Clone Data to get rid of References, so we always copy here
Dim ProcessedBits(_ProcessedBits.GetUpperBound(0))() As Byte
For i = 0 To _ProcessedBits.Length - 1
ProcessedBits(i) = _ProcessedBits(i).Clone()
Next
Dim FinalString As String = _FinalString.Clone()
Dim LoopTwo As Boolean = False
Dim ExitedTooSoon As Boolean = False
Dim CurrentOffset As UInteger = GetCurrentOffsetForRow(Uniques, CurrentRow, ProcessedBits)
Dim solutionsRows As New List(Of UInteger)
While True
'If finished with everything just simply exit this loop
If bitmask.Length = CurrentProcessedByte Then Exit While
'Unique currently on this row no need any extra processing
If bitmask(CurrentProcessedByte) = 0 Then
'Bad Sub Node.. exit it
If Uniques(CurrentRow).Length = CurrentOffset Then
ExitedTooSoon = True
Exit While
End If
FinalString = FinalString & " " & Uniques(CurrentRow)(CurrentOffset)
'Mark as processed for future calculations
ProcessedBits(CurrentRow)(CurrentOffset) = 1
End If
'Switch to a new row
If bitmask(CurrentProcessedByte) = 1 Then
'Get all possible solutions first
solutionsRows.Clear()
PreviousRow = CurrentRow
Dim MainRowUniquesUsed() As Byte
MainRowUniquesUsed = GetUniquesAt(Uniques, PreviousRow, ProcessedBits)
CurrentRow = 0
If LoopTwo Then
'Get all the right value each row solutions
Dim LastRowUsed As Boolean = False
While True
If CurrentRow >= Uniques.Length Then Exit While
'Is Row accessible, like does the row come after a row that was used previously.
If ProcessedBits(CurrentRow)(0) = 1 OrElse ((CurrentRow - 1 >= 0) AndAlso ProcessedBits(CurrentRow - 1)(0) = 1) Then
LastRowUsed = True
End If
If LastRowUsed Then
Dim ValueNotUsed() As Byte = Uniques(CurrentRow) _
.Select(Function(item, index) New With {.Item = item, .Index = index}) _
.Where(Function(x) ProcessedBits(CurrentRow)(x.Index) = 0) _
.Select(Function(x) x.Item).ToArray()
If ValueNotUsed.Length > 0 AndAlso MainRowUniquesUsed.Contains(ValueNotUsed(0)) Then
solutionsRows.Add(CurrentRow)
End If
End If
'Row incrementer
If CurrentRow + 1 = PreviousRow Then
CurrentRow = CurrentRow + 2
Else
CurrentRow = CurrentRow + 1
End If
LastRowUsed = False
End While
CurrentRow = 0
'Run sub-nodes on every possible solution.
For Each Row In solutionsRows
Dim PreviousRowSpoofed As UInteger = PreviousRow
Dim CurrentRowSpoofed As UInteger = Row
Process(FinalString, ProcessedBits, CurrentProcessedByte, PreviousRowSpoofed, CurrentRowSpoofed)
Next
End If
Dim CurrentRowUniques() As Byte
While True
MainRowUniquesUsed = GetUniquesAt(Uniques, PreviousRow, ProcessedBits)
If (PreviousRow = CurrentRow) AndAlso CurrentRow = 0 Then
CurrentRow = 1
ElseIf (PreviousRow = CurrentRow) AndAlso CurrentRow > 0 Then
CurrentRow = 0
End If
CurrentRowUniques = GetUniquesAt(Uniques, CurrentRow, ProcessedBits)
CurrentOffset = GetCurrentOffsetForRow(Uniques, CurrentRow, ProcessedBits)
'Quick fix
If MainRowUniquesUsed Is Nothing Then
CurrentRow = PreviousRow
CurrentOffset = GetCurrentOffsetForRow(Uniques, CurrentRow, ProcessedBits)
FinalString = FinalString & " " & Uniques(CurrentRow)(CurrentOffset)
'Mark as processed for future calculations
ProcessedBits(CurrentRow)(CurrentOffset) = 1
LoopTwo = True
Exit While
End If
'Next Row is blank, then its just a fresh entry
If CurrentRowUniques Is Nothing Then
FinalString = FinalString & " " & Uniques(CurrentRow)(CurrentOffset)
'Mark as processed for future calculations
ProcessedBits(CurrentRow)(CurrentOffset) = 1
LoopTwo = True
Exit While
'Scan this row if its a possible insert here or possible go to next
End If
If CurrentRowUniques IsNot Nothing Then
Dim ValueNotUsed() As Byte = Uniques(CurrentRow) _
.Select(Function(item, index) New With {.Item = item, .Index = index}) _
.Where(Function(x) ProcessedBits(CurrentRow)(x.Index) = 0) _
.Select(Function(x) x.Item).ToArray()
'If no values are possible, then go check next row.
If ValueNotUsed.Length = 0 Then
'If the Next Row is the Row we were in, just before this one Jump 2 rows
If CurrentRow + 1 = PreviousRow Then
CurrentRow = CurrentRow + 2
Else
CurrentRow = CurrentRow + 1
End If
'This quick fix isn't checked could be wrong
'it just starts from the top if it hit a row past the last row.
If CurrentRow >= Uniques.Length Then
ExitedTooSoon = True
Exit While
End If
Continue While
'This is a possible answer area (where it would spawn multiple nodes to keep recursively finishing it.)
ElseIf ValueNotUsed.Length > 0 Then
If Not MainRowUniquesUsed.Contains(ValueNotUsed(0)) Then
'The next pattern isn't found in this Row, so we hope next row.
'Keep hopping rows until we hit the row which is the farthest one
'Then we could exit out.
'If the Next Row is the Row we were in, just before this one Jump 2 rows
If CurrentRow + 1 = PreviousRow Then
CurrentRow = CurrentRow + 2
Else
CurrentRow = CurrentRow + 1
End If
If CurrentRow + 1 > PreviousRow Then
'Hit the row we currently on and still no match so its a bad loop
ExitedTooSoon = True
Exit While
ElseIf CurrentRow >= Uniques.Length Then
ExitedTooSoon = True
Exit While
End If
Continue While
End If
'Scan Previous Rows for the same answer as in this Row.
FinalString = FinalString & " " & Uniques(CurrentRow)(CurrentOffset)
'Mark as processed for future calculations
ProcessedBits(CurrentRow)(CurrentOffset) = 1
LoopTwo = True
Exit While
End If
End If
If FailedPaths.Contains(FinalString) Then
ExitedTooSoon = True
Exit While
End If
End While
End If
If ExitedTooSoon Then
Exit While
End If
CurrentOffset += 1
CurrentProcessedByte += 1
End While
If ExitedTooSoon Then
FailedPaths.Add(FinalString)
Exit Sub
End If
Dim output As String
output = output & "TreeNode Decoded Answer: " & FinalString & vbCrLf
output = output & "Stopped at row: " & CurrentRow & vbCrLf
txtOutput.Text = txtOutput.Text & output
End Sub
Simply make a array to hold your solutions then loop each one to create a new call to the same data like so
For Each Row In solutionsRows
Process(FinalString, ProcessedBits, CurrentProcessedByte, PreviousRow, Row)
Next
For j = 0 To 20
For i = 0 To 20
ReDim atoms(0 To 20, 0 To 20)
ReDim atomschange(0 To 20, 0 To 20)
atomschange(j, i) = 0
If i Mod 2 = 0 And j Mod 2 = 0 Then
[B2].Offset(j, i).Interior.ColorIndex = 37
atoms(j, i) = 1
Else
[B2].Offset(j, i).Interior.ColorIndex = 36
atoms(j, i) = 0
End If
Next i
Next j
End Sub
what am i doing wrong?
You are redim'ing your arrays inside a loop which reinitializes, then dropping any data inside the array. Use the PRESERVE keyword to insure you don't dump your array when redimensioning it ReDim Preserve atoms(0 To 20, 0 To 20)
Redimensioning your arrays to the exact same size makes no sense. They are already 0 To 20, 0 To 20 because you already set that. Redim them once outside of your for loops and then leave them alone.
Insure that your atoms and atomschange arrays are declared properly at the top of your code. It's complaining (probably when you redim them) that those two variables aren't arrays.
You know the size of the arrays before this code executes, so declare them and dim them properly in the declaration, then just use them (removing the superfluous and incorrect use of redim in your loop:
Sub somesumroutine()
Dim atoms(0 to 20, 0 to 20) as Integer
Dim atomschange(0 to 20, 0 to 20) as Integer
For j = 0 To 20
For i = 0 To 20
atomschange(j, i) = 0
If i Mod 2 = 0 And j Mod 2 = 0 Then
[B2].Offset(j, i).Interior.ColorIndex = 37
atoms(j, i) = 1
Else
[B2].Offset(j, i).Interior.ColorIndex = 36
atoms(j, i) = 0
End If
Next i
Next j
End Sub
Consider using UBound and LBound of your atoms array to set the loops so you don't have to use the 0 to 20 over and over again. This way you can dim your arrays once and leave the rest of your code alone:
Sub somesumroutine()
Dim atoms(0 to 20, 0 to 20) as Integer
Dim atomschange(0 to 20, 0 to 20) as Integer
For j = lBound(atoms, 1) To uBound(atoms, 1)
For i = lBound(atoms, 2) To uBound(atoms, 2)
atomschange(j, i) = 0
If i Mod 2 = 0 And j Mod 2 = 0 Then
[B2].Offset(j, i).Interior.ColorIndex = 37
atoms(j, i) = 1
Else
[B2].Offset(j, i).Interior.ColorIndex = 36
atoms(j, i) = 0
End If
Next i
Next j
End Sub
I am trying to construct and If statement that turns a tab Red if two of three cells are colored, or Turns green if only on is colored. I was hoping that there would be an easier way to right it than three if statements like this.
Dim dateRng As String, num As Integer, j As Integer, irng As Range, frng As Range
dateRng = Sheets("Input Raw Data").Range("B" & counter + 2).Value
num = Sheets("Tool Setup").Range("C18").Value
NumPts = num * 3
For s = 1 To Sheets.Count
With Sheets(s)
For j = 1 To num
If .Name = j Then
.Range("A1:C1").Merge
.Range("A1") = dateRng
.Name = Sheets("Point Names").Range("B" & (3 * j - 1))
End If
Next j
End With
Next s
For s = 1 to Sheets.Count
With Sheets(s)
For y = 1 To NumPts
If .Name = Sheets("Reporting").Range("B" & (12 * y - 5)) Then
For k = 6 To -1
Set irng = Sheets("Reporting").Range("A" & (12 * y - k))
Set irng = Sheets("Reporting").Range(irng, irng.End(xlToRight).End(xlToRight))
irng.Copy (.Range("A2"))
Next k
.Columns("A:A").ColumnWidth = 12
.Columns("B:B").EntireColumn.AutoFit
If .Range("B7").Interior.ColorIndex > 0 Then
a = 1
End If
If .Range("B8").Interior.ColorIndex > 0 Then
a = a + 1
End If
If .Range("B9").Interior.ColorIndex > 0 Then
a = a + 1
End If
If a >= 2 Then
.Tab.ColorIndex = 3
ElseIf a <= 1 Then
.Tab.ColorIndex = 4
End If
End If
y = y + 2
Next y
End With
Next s
Something like this may help you. It still has multiple if statements. But the statements are simple and don't have to deal with how the combinations of different cells being colored.
Also, I used colorindex > 0 as the condition for having color filling.
a = 0
If .Range("B7").Interior.ColorIndex > 0 Then
a = 1
End If
If .Range("B8").Interior.ColorIndex > 0 Then
a = a + 1
End If
If .Range("B9").Interior.ColorIndex > 0 Then
a = a + 1
End If
If a = 2 Then
.Range("B10").Interior.ColorIndex = 3
ElseIf a = 1 Then
.Range("B10").Interior.ColorIndex = 43
End If
I have a program Sub which works well. I want to convert it into a custom Function, but when I use this function in Excel an error (#VALUE!) occurs
Function ТридцатьТРи(Diapozon As Integer)
'для п/пр
Dim k, n As Integer
Dim parRange As Range
Set parRange = Range("Diapozon")
k = 0
n = 0
For Each Cell In parRange.Rows
If Cell.Offset(0, 1).Value = 1 And k = -1 Then
n = n - 1
End If
If Cell.Value = 1 And k = -1 Then
n = n + 1
End If
If Cell.Value = 1 Then
k = k + 1
If k = 2 Then
k = -1
End If
End If
If Cell.Value = 2 Or Cell.Value = 3 Then
k = 0
End If
Next Cell
ТридцатьТРи = n
End Function
Try the UDF code below (not sure about what you are trying to achieve with your logics inside the UDF), but it works (not getting #VALUE!).
Since you want to pass a Range object to the UDF (according to your screen-shot), you need to define it also in your Function code.
Code
Function cyrilic(Diapozon As Range) As Long
Dim k As Long, n As Long
Dim C As Range
k = 0
n = 0
For Each C In Diapozon.Rows
If C.Offset(0, 1).Value = 1 And k = -1 Then
n = n - 1
End If
If C.Value = 1 And k = -1 Then
n = n + 1
End If
If C.Value = 1 Then
k = k + 1
If k = 2 Then
k = -1
End If
End If
If C.Value = 2 Or C.Value = 3 Then
k = 0
End If
Next C
cyrilic = n
End Function
This will work as a worksheet function apperently, you need to input the range that you previousely defined with a named range "diapozon" as an input range.
Function cyrillic(rng As Range)
Dim k, n As Integer
Dim parRange As Range
Set parRange = rng
k = 0
n = 0
For Each Cell In parRange.Rows
If Cell.Offset(0, 1).Value = 1 And k = -1 Then
n = n - 1
End If
If Cell.Value = 1 And k = -1 Then
n = n + 1
End If
If Cell.Value = 1 Then
k = k + 1
If k = 2 Then
k = -1
End If
End If
If Cell.Value = 2 Or Cell.Value = 3 Then
k = 0
End If
Next Cell
cyrillic = n
End Function
Just type : =cyrillic("R1:RX") and it should work.