Hi struggling with some basic code ... could someone please explain this code, why does it shove 2 extra lines on the end ...
Sub main()
Dim item As Variant
Dim ifToSave As Variant
Dim fileType(5) As String
fileType(0) = "1"
fileType(1) = "2"
fileType(2) = "3"
fileType(3) = "4"
fileType(4) = "5"
For Each item In fileType
ifToSave = item & " - apple"
Debug.Print item
Debug.Print ifToSave
Next item
End Sub
Outputs this
1
1 - apple
2
2 - apple
3
3 - apple
4
4 - apple
5
5 - apple
- apple
Where this doesnt
For i = 1 To 5
ifToSave = i & " - apple"
Debug.Print i
Debug.Print ifToSave
Next i
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
I have been trying to figure out how to force word tables to under line until the end of the cell. I appear to be having issues if lines are to long and/or to short. I am not a word expert, however I am assuming that all characters are not the same size...
This is what the code produces
Below is the code I used to create the above. I would think that I should be able to check the cell length? Any help would be appreciated.
Public Shared Sub CreateWordDocument()
Try
Dim oWord As Word.Application
Dim oDoc As Word.Document
'Start Word and open the document template.
oWord = CreateObject("Word.Application")
oWord.Visible = True
oDoc = oWord.Documents.Add
Dim Row As Integer, Column As Integer
Dim myTable As Word.Table = oDoc.Tables.Add(oDoc.Bookmarks.Item("\endofdoc").Range, 10, 2)
myTable.Range.ParagraphFormat.SpaceAfter = 1
Dim mystring As String = "This is my Test name That Runs over to the next line"
Dim address1 As String = "123 1st fake street"
Dim address2 As String = "Fake town place"
Dim mystring2 As String = "This is good line"
Dim address3 As String = "321 3rd fake street"
Dim address4 As String = "Fake town place"
Dim line As String = "_"
For Row = 1 To 10
If Row <> 5 Then
myTable.Rows.Item(Row).Range.Font.Underline = Word.WdUnderline.wdUnderlineSingle
myTable.Rows.Item(Row).Range.ParagraphFormat.Alignment = Word.WdParagraphAlignment.wdAlignParagraphLeft
myTable.Rows.Item(Row).Range.Font.Bold = False
myTable.Rows.Item(Row).Range.Font.Size = 11
myTable.Rows.Item(Row).Range.Font.Underline = Word.WdUnderline.wdUnderlineSingle
End If
For Column = 1 To 2
If Column = 1 And Row = 1 Then
myTable.Cell(Row, Column).Range.Text = GetString(mystring)
ElseIf Column = 1 And Row = 2 Then
myTable.Cell(Row, Column).Range.Text = GetString(address1)
ElseIf Column = 1 And Row = 3 Then
myTable.Cell(Row, Column).Range.Text = GetString(address2)
ElseIf Column = 2 And Row = 1 Then
myTable.Cell(Row, Column).Range.Text = GetString(mystring2)
ElseIf Column = 2 And Row = 2 Then
myTable.Cell(Row, Column).Range.Text = GetString(address3)
ElseIf Column = 2 And Row = 3 Then
myTable.Cell(Row, Column).Range.Text = GetString(address4)
Else
myTable.Cell(Row, Column).Range.Text = GetString(line)
End If
Next
Next
Dim strCellText As String
Dim uResp As String
Dim itable As Table
For Each itable In oDoc.Tables
uResp = ""
For Row = 1 To itable.Rows.Count
For Col = 1 To itable.Columns.Count
strCellText = itable.Cell(Row, Col).Range.Text
If strCellText.Length >= 33 Then
Console.Write("this will be on a different line")
ElseIf strCellText.Length <= 31 Then
Console.Write("this will be on a different line")
End If
Next
Next
Next
Catch ex As Exception
End Try
End Sub
Public Shared Function GetString(ByVal strGetLine As String) As String
If strGetLine.Length <> 30 Then
Do Until strGetLine.Length >= 30
strGetLine += "_"
Dim count As String = strGetLine.Length
Loop
End If
Return strGetLine
End Function
There are two parts to your problem. One is the font. Because you are padding each line with "_" to a predetermined width, you must use a monospaced font or the lines will end unevenly. With a monospaced font, each character will take up the same width which will give you your uniform lines. Second, the GetString function takes any line less than 30 characters and pads it, but it does not handle any lines that are over 30 characters which is why the line wraps by itself. To solve these two problems, I set the font to a monospaced font (Courier New in this case) and modified the GetString function's logic. Now, if the line is more than 30 characters, the function will find a space where it can split the string as close as possible to the 30-char limit and add a break there, before padding both lines with underscores. Here is your code with the changes included:
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
'Added these two Dim's so I could run your example
Dim oWord As Object
Dim oDoc As Document
oWord = CreateObject("Word.Application")
oWord.Visible = True
oDoc = oWord.Documents.Add
Dim Row As Integer, Column As Integer
Dim myTable As Word.Table = oDoc.Tables.Add(oDoc.Bookmarks.Item("\endofdoc").Range, 10, 2)
myTable.Range.ParagraphFormat.SpaceAfter = 1
Dim mystring As String = "This is my Test name That Runs over to the next line"
Dim address1 As String = "123 1st fake street"
Dim address2 As String = "Fake town place"
Dim mystring2 As String = "This is good line"
Dim address3 As String = "321 3rd fake street"
Dim address4 As String = "Fake town place"
Dim line As String = "_"
For Row = 1 To 10
'Removed this If, because all lines need font set to ensure same width, even if line has no text
'If Row <> 5 Then
myTable.Rows.Item(Row).Range.Font.Underline = Word.WdUnderline.wdUnderlineSingle
myTable.Rows.Item(Row).Range.ParagraphFormat.Alignment = Word.WdParagraphAlignment.wdAlignParagraphLeft
myTable.Rows.Item(Row).Range.Font.Bold = False
myTable.Rows.Item(Row).Range.Font.Size = 11
myTable.Rows.Item(Row).Range.Font.Underline = Word.WdUnderline.wdUnderlineSingle
myTable.Rows.Item(Row).Range.Font.Name = "Courier New" 'Set font to a monospaced font
'End If
For Column = 1 To 2
If Column = 1 And Row = 1 Then
myTable.Cell(Row, Column).Range.Text = GetString(mystring)
ElseIf Column = 1 And Row = 2 Then
myTable.Cell(Row, Column).Range.Text = GetString(address1)
ElseIf Column = 1 And Row = 3 Then
myTable.Cell(Row, Column).Range.Text = GetString(address2)
ElseIf Column = 2 And Row = 1 Then
myTable.Cell(Row, Column).Range.Text = GetString(mystring2)
ElseIf Column = 2 And Row = 2 Then
myTable.Cell(Row, Column).Range.Text = GetString(address3)
ElseIf Column = 2 And Row = 3 Then
myTable.Cell(Row, Column).Range.Text = GetString(address4)
Else
myTable.Cell(Row, Column).Range.Text = GetString(line)
End If
Next
Next
Dim strCellText As String
Dim uResp As String
Dim itable As Table
For Each itable In oDoc.Tables
uResp = ""
For Row = 1 To itable.Rows.Count
For Col = 1 To itable.Columns.Count
strCellText = itable.Cell(Row, Col).Range.Text
If strCellText.Length >= 33 Then
Console.Write("this will be on a different line")
ElseIf strCellText.Length <= 31 Then
Console.Write("this will be on a different line")
End If
Next
Next
Next
End Sub
Public Shared Function GetString(ByVal strGetLine As String) As String
'If strGetLine.Length <> 30 Then
' Do Until strGetLine.Length >= 30
' strGetLine += "_"
' Dim count As String = strGetLine.Length
' Loop
'End If
'New Function Logic:
'If the line is just a blank line, then just send back 30 underscores
If strGetLine.Trim.Equals("_") Then Return strGetLine.PadRight(30, "_")
Dim ret As String = Nothing
If strGetLine.Length > 30 Then
Dim lineBreak As Integer = 0
If strGetLine.Length >= 30 Then
Dim i As Integer = 0
Do While i <= 30
i = strGetLine.IndexOf(" ", i + 1)
If i <= 30 Then lineBreak = i
Loop
End If
ret = strGetLine.Substring(0, lineBreak).Trim.PadRight(30, "_") & vbCrLf
ret &= strGetLine.Substring(lineBreak, strGetLine.Length - lineBreak).Trim.PadRight(30, "_")
Else
ret = strGetLine.PadRight(30, "_")
End If
Return ret
End Function
Which outputs:
Now I'm sure you'll notice, there appears to be a blank line in the right column (the rest of the blank lines are from the 10 row loop). This is simply because the other column of the same row has two lines. I don't know if that's what you would want or not, but if you want both columns to have the appearance of the same number of lines, you will have to keep track of if you split a line in column 1, and add an extra blank line to column two...but this should get you going in the right direction
Im having a trouble understanding For and Do while.
Im trying to put items in a listbox in this order:
1 2 3 4 5 6 7 8 9 10
1 2 3 4 5 6 7 8 9
1 2 3 4 5 6 7 8
and so on.
And the same way around
1
1 2
1 2 3
Up intil 10
How should i attack this issue?
This is what im stuck with:
Dim counter1 As Integer
Dim counter2 As Integer
For counter1 = 10 To 1 Step -1
For counter2 = 1 To 10
ListBox1.Items.Add()
Next counter2
Next counter1
Your problem is not with using the Loops alone but with using the ListBox Methods. You can achieve what you want in 2 ways:
Initially concatenate (connect) the numbers into a single string and then add it on the Listbox using AddItem Method.
Populate a multicolumn ListBox using a nested loop using AddItem and List method.
The first one should be something like below:
Private Sub CommandButton1_Click()
Dim i As Integer, j As Integer, k As Integer
Dim s As String
k = 11 ' this determines the exit condition
For i = 1 To 10
For j = 1 To 10
If k = j Then Exit For
s = IIf(s = "", j, s & " " & j) ' construct the string
Next
Me.ListBox1.AddItem s ' add in listbox
s = ""
k = k - 1
Next
End Sub
Which will result to:
Edit1 No.2 Above
Private Sub CommandButton1_Click()
Dim i As Integer, j As Integer, k As Integer
With Me.ListBox1
.ColumnCount = 10
.ColumnWidths = "15;15;15;15;15;15;15;15;15;15"
k = 10 ' determines exit condition
For i = 1 To 10
For j = 1 To 10
If j = 1 Then
.AddItem j ' if it is the number 1, use AddItem method
Else
.List(.ListCount - 1, j - 1) = j ' else use the List method
End If
If k = j Then Exit For
Next
k = k - 1
Next
End With
End Sub
This time, we do not add concatenated numbers into the ListBox but we add it 1 by 1 in each row and column of a multicolumn ListBox. Result would be:
I leave the ascending numbers to you. :) I hope this gets you going.
I am getting the 1004 error when running. The error is at this line:
If IsNumeric(wkbCurr.Sheets(CTRYname).Range(column & x).Value) = True Then
What I want to do is to select the sheet (CTRYNAME) and then search through columns 5,7,9 etc and format the numbers as done in the code.
Public Sub MoM_Check()
Dim inti As Integer
Dim intj As Integer
Dim k As Integer
Dim mnth As Integer
Dim currSALE As Double
Dim prevSALE As Double
Dim diffpercent As Double
Dim CTRYname As String
Dim x As Integer
Dim column As String
'Find Difference percentage between sales of 24 common months in present month's extarct and previous month's extract
For n = 1 To 13
Application.SheetsInNewWorkbook = 4
Set wkbTemp = Workbooks.Add
CTRYname = ThisWorkbook.Sheets("Country lookup").Range("A1").Offset(n, 0).Value
'Open a temporary workbook to do all the Calculations
'First the current month's extract is copied to the first sheet
'We now copy sheets for range from wkbout to wkbtemp using usedrange
wkbCurr.Sheets(CTRYname).Activate
wkbCurr.Sheets(CTRYname).UsedRange.Copy
wkbTemp.Sheets("Sheet1").Range("A1").PasteSpecial
wkbprev.Sheets(CTRYname).Activate
wkbprev.Sheets(CTRYname).UsedRange.Copy
wkbTemp.Sheets("Sheet2").Range("A1").PasteSpecial
'open the Previous month's Main Extract file as given in the lookup tab. This data is pasted on sheet2 of temporary workbook.
'This sheet helps us to compare the country channels in current month's extract with the previous Month's Extract.
'So the same process is followed for this sheet and similarly we get the country channels from the previous month's extract and paste them on 'sheet3
'Prevcnt contains the number of country channels in the previous month's extract
k = 1
For mnth = 0 To 22
currSALE = wkbTemp.Sheets("Sheet1").Range("AB10").Offset(0, mnth).Value
prevSALE = wkbTemp.Sheets("Sheet2").Range("AC10").Offset(0, mnth).Value
If prevSALE = 0 And currSALE <> 0 Then
diffpercent = 1
ElseIf prevSALE = 0 And currSALE = 0 Then
diffpercent = 0
Else: diffpercent = (currSALE - prevSALE) / prevSALE
End If
If diffpercent > 0.01 Or diffpercent < -0.01 Then
Set wkbRaw = Workbooks.Open(strOutputQCPath & "Errorlog.xlsx")
wkbRaw.Sheets("Sheet1").Activate
wkbRaw.Sheets("Sheet1").Range("A1").Offset(i, 1 + n).Value = CTRYname & " Incorrect"
Exit For
Else
Set wkbRaw = Workbooks.Open(strOutputQCPath & "Errorlog.xlsx")
wkbRaw.Sheets("Sheet1").Activate
wkbRaw.Sheets("Sheet1").Range("A1").Offset(i, 1 + n).Value = CTRYname & " Correct"
k = k + 1
wkbRaw.SaveAs Filename:=strOutputQCPath & "Errorlog.xlsx"
wkbRaw.Close
End If
Next mnth
For x = 1 To 15
If x = 1 Or x = 2 Or x = 3 Or x = 4 Or x = 6 Or x = 9 Or x = 10 Or x = 11 Or x = 13 Then
GoTo Name
Else
If IsNumeric(wkbCurr.Sheets(CTRYname).Range(column & x).Value) = True Then
If wkbCurr.Sheets(CTRYname).Range(column & x).Value > 9.99 Then
wkbCurr.Sheets(CTRYname).Range(column & x).Value = ">999%"
ElseIf wkbCurr.Sheets(CTRYname).Range(column & x).Value < -9.99 Then
wkbCurr.Sheets(CTRYname).Range(column & x).Value = "<-999%"
End If
End If
End If
Name:
Next x
wkbTemp.Close savechanges:=False
Set wkbTemp = Nothing
Next n
End Sub
Please help!
You haven't given the string "column" a value, which is why you're getting error 1004 on that line.