Search in a two-dimensional array - vb.net

I'm trying to find the values in different points of the array. When I run the code, it always goes to The value doesn't exists, also I do not know how to count the values that are same r.
r = 0
c = txtbbus.Text
For i = 0 To n - 1
For j = 0 To n - 1
If a(i, j) = c Then
txtbres.Text = "The value exists " & r & " and it's in the position (" & i & ", " & j & ") "
Else
txtbres.Text = "The value doesn't exists"
End If
Next j
Next i
And this is how I initialize a:
txtbmatriz.Text = ""
For i = 0 To n - 1
For j = 0 To n - 1
a(i, j) = CInt((100 * Rnd()) + 1)
txtbmatriz.Text += a(i, j) & " "
m += a(i, j)
l += 1
Next j
txtbmatriz.Text += vbCrLf
Next i

The problem is almost certainly that you don't break out of the loop when you find a match. Your code will only ever show you the result of the last element in the array because you always keep searching to the last element. Once you find a match, there's no point to looking further and, in fact, doing so is detrimental. Once you find a match, stop looking.
Finding a single/first match:
Dim rng As New Random
Dim matrix = New Integer(9, 9) {}
For i = 0 To matrix.GetUpperBound(0)
For j = 0 To matrix.GetUpperBound(1)
matrix(i, j) = rng.Next(1, 101)
Next
Next
Dim target = rng.Next(1, 101)
Dim message As String
For i = 0 To matrix.GetUpperBound(0)
For j = 0 To matrix.GetUpperBound(1)
If matrix(i, j) = target Then
message = $"{target} found at ({i},{j})"
Exit For
End If
Next
If message IsNot Nothing Then
Exit For
End If
Next
Console.WriteLine(If(message, $"{target} not found"))
Finding all matches:
Dim rng As New Random
Dim matrix = New Integer(9, 9) {}
For i = 0 To matrix.GetUpperBound(0)
For j = 0 To matrix.GetUpperBound(1)
matrix(i, j) = rng.Next(1, 101)
Next
Next
Dim target = rng.Next(1, 101)
Dim matches As New List(Of String)
For i = 0 To matrix.GetUpperBound(0)
For j = 0 To matrix.GetUpperBound(1)
If matrix(i, j) = target Then
matches.Add($"({i},{j})")
End If
Next
Next
Console.WriteLine(If(matches.Any(),
$"{target} found at {String.Join(", ", matches)}",
$"{target} not found"))

Try this:
r = 0
c = txtbbus.Text
Dim i As Integer
Dim j As Integer
Dim FoundMatch As Boolean = False
For i = 0 To n - 1
For j = 0 To n - 1
If a(i, j) = c Then
FoundMatch = True
Exit For
End If
Next j
If FoundMatch = True Then
Exit For
End If
Next i
If FoundMatch = True Then
txtbres.Text = "The value exists " & r & " and it's in the position (" & i & ", " & j & ") "
Else
txtbres.Text = "The value doesn't exists"
End If

I'm going to assume c = txtbbus.Text is from some form input. Meaning a string. For the equality check you'd be testing against an Int type. Try casting the input from txtbbus.Text as an integer. Also, like the other poster said breaking from the loop on finding your match would also be a good decision.

Related

Extract mathmatical and greek superscripts in Word VBA

I need to build a list of superscripts in a document which is fine until I get to symbols for things like partial derivatives which instead return as ? in my array instead of ∂. What could I add to capture the actual symbol? Thanks
Dim i As Long, j As String
Dim txtboxString() As String
Dim Superscript As String
Dim myrange As range
Dim ap As Document: Set ap = ActiveDocument
x = 0
For i = 1 To ap.Characters.Count
j = ""
If ActiveDocument.Characters(i).Font.Superscript = True Then
Z = 0
ReDim Preserve txtboxString(x + 1)
For Z = i To i - 5 Step -1
If Z > ap.Characters.Count Then GoTo 1
If ActiveDocument.Characters(Z) = "," Then GoTo 0
If ActiveDocument.Characters(Z).Font.Superscript = True Then j = ActiveDocument.Characters(Z) & j
Next Z
End If
0: If j <> "" Then
If j <> "," Then
If j <> "?" Then
txtboxString(x) = j
x = x + 1
End If
End If
End If
If Z + 1 > ap.Characters.Count Then i = Z 'Else i = Z + 1
Set myrange = ActiveDocument.Characters(i + 1)
myrange.MoveUntil Cset:="* "
i = myrange.End - 1
Next

Generate list from strings and numbers vba

This question is based on this puzzle that I am trying to do in vba: https://codegolf.stackexchange.com/questions/166765/fun-with-strings-and-numbers
Basically we have strings in col A and numbers in column B and in column C we have to generate a list so that:
The total count of any string should be exactly equal to its
corresponding number in the input data.
No string should be repeated adjacently in the sequence, and every
string should appear in the output list.
The selection of the next string should be done randomly as long as
they don't break above two rules. Each solution should have a
non-zero probability of being chosen.
If no combination is possible, the output should be just 0.
I tried this but I don't how to solve the problem so that it doesn't break rule #2. Any input would be appreciated thanks.
Sub generateList()
Application.ScreenUpdating = False
Dim fI As Long, totTimes As Long, i As Long, j As Long, fO As Long, tryCount As Long
Dim myArr()
Dim randNum As Long
OUT.Range("A1:A" & OUT.Rows.Count).Clear
fO = 1
With DATA
fI = .Range("A" & .Rows.Count).End(xlUp).Row
If fI < 2 Then MsgBox "No data!": Exit Sub
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("B2:B" & fI), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With DATA.Sort
.SetRange DATA.Range("A1:B" & fI)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
fI = .Range("A" & .Rows.Count).End(xlUp).Row
If fI < 2 Then MsgBox "No data!": Exit Sub
totTimes = 0: j = 0
For i = 2 To fI
If Trim(.Range("A" & i).Value) <> "" And IsNumeric(.Range("B" & i).Value) Then j = j + 1
Next i
If j < 1 Then MsgBox "No valid data present. Make sure column B has numbers and column A some string.": Exit Sub
ReDim Preserve myArr(1 To j, 1 To 2)
j = 0
For i = 2 To fI
If Trim(.Range("A" & i).Value) <> "" And IsNumeric(.Range("B" & i).Value) Then
totTimes = totTimes + CLng(.Range("B" & i).Value)
j = j + 1
myArr(j, 1) = .Range("A" & i)
myArr(j, 2) = .Range("B" & i)
End If
Next i
Do While totTimes > 0
randNum = WorksheetFunction.RandBetween(1, j)
If myArr(randNum, 2) > 0 Then
totTimes = totTimes - 1
OUT.Range("A" & fO) = myArr(randNum, 1)
myArr(randNum, 2) = myArr(randNum, 2) - 1
fO = fO + 1
End If
tryAgain:
Loop
End With
Application.ScreenUpdating = True
OUT.Activate
MsgBox "Process Completed"
End Sub
I have a solution (that isn't based on yours, unfortunately) that gives correct results... some of the time. I think I know why it falls short, I just have given up on fixing it.
It's also terrible for golfing, since it's a rather large amount of code, and it's an unholy mishmash of different approaches and implementation ideas that I made up as I went (and I never cleaned it up properly)... but maybe some of this will inspire you to get further.
As per rule #3, I select each letter at random. It was hit and miss using only that approach so I moved to weighted probabilities, which is what the code further down uses - and it seems to work somewhat well. Occasionally there will be 1 letter too many for one of the elements, or there will be adjacent equal elements, so it doesn't actually solve the puzzle all the time.
Ideas to remedy this problem:
Adjust the probability weights based on the frequency each letter has already been used. If you set dbg to true, you'll see that I implemented some calculations with that in mind, but never got around to figuring out how to actually adjust the weights themselves.
Hardcode a check or two for how many letters have been used early in the result, for the largest element group
Change the rand section to make more than 1 pass (maybe best out of 3) - the weights are sorted by "size", so doing 3 (or n) passes should increasingly favor the larger element groups
Maybe a combination of the first and the last suggestion.
Here's the code:
Sub NonRepeatSort(v() As String)
Dim lElementCount As Long
Dim lElement As Element ' Largest
Dim tElement As Long ' Total element count
Dim tEleGroups As Long ' Number of groups of elements
Dim tEle As Element
Dim e As Element
Dim EleCol As New Collection
Dim dbg As Boolean
dbg = False
Dim s As String, res As String, previousRes As String, inputString As String
Dim lCounter As Long
For i = 1 To UBound(v)
' Check if element already exists
On Error Resume Next
s = ""
s = EleCol.Item(v(i, 1))
On Error GoTo 0
' If not, create new
If s = "" Then
Set tEle = New Element
With tEle
.SetName = v(i, 1)
.SetTotal = CLng(v(i, 2))
End With
EleCol.Add Item:=tEle, Key:=tEle.Name
End If
Next i
For Each e In EleCol
' Find the largest element
If e.Total > lElementCount Then
lElementCount = e.Total
Set lElement = e
End If
' Count total elements
tElement = tElement + e.Total
' And groups
tEleGroups = tEleGroups + 1
' Generate inputstring
For k = 1 To e.Total
inputString = inputString + e.Name
Next k
Next e
' If the largest element is larger than the total remaining elements, we'll break rule 4
If lElement.Total - (tElement - lElement.Total) > 1 Then
Debug.Print "0"
GoTo EndForSomeReason
End If
' Bubble sort - lowest to highest
' Adapted from https://stackoverflow.com/a/3588073/4604845
Dim tmpE As Element
For x = 1 To EleCol.Count - 1
For y = 1 To EleCol.Count
If EleCol.Item(x).Total > EleCol.Item(y).Total Then
Set tmpE = EleCol.Item(y)
EleCol.Remove y
EleCol.Add tmpE, tmpE.Name, x
End If
Next y
Next x
' Weighted probability array
Dim pArr() As Variant, tmpProb As Double
ReDim Preserve pArr(1 To 2, 1 To EleCol.Count)
For u = 1 To UBound(pArr, 2)
Set pArr(2, u) = EleCol.Item(u)
tmpProb = tmpProb + pArr(2, u).Freq(tElement)
pArr(1, u) = tmpProb
Next u
' The meat of it
Dim r As Long, lBool As Boolean, sLen As Long, o As Double, t As Long
For j = 1 To tElement
Do
' Reset loop control
lBool = False
' Generate a random number between 1 and 100 _
to decide which group we pick a letter from
r = Rand1To100
For i = 1 To UBound(pArr, 2)
If r <= pArr(1, i) And Not r > pArr(1, i) Then
If dbg Then Debug.Print "Probability match: " & pArr(2, t).Name
t = i
Exit For
End If
Next i
Set tEle = EleCol.Item(t)
If dbg Then Debug.Print "Name: " & tEle.Name
' If the random group is different from the previous result, proceed
If tEle.Name <> previousRes Then
lBool = True
Else
If dbg Then Debug.Print "This was also the previous result - skipping"
End If
' If the use-frequency for the random group is lower than _
how many times it appears in the string, proceed
If lBool Then
o = Round((tEle.Used / tElement) * 100, 5)
If dbg Then Debug.Print "Freq: " & tEle.Freq(tElement)
If dbg Then Debug.Print "Used: " & tEle.UsedFreqI()
If dbg Then Debug.Print "res%: " & Round((Len(res) / tElement) * 100, 1)
If dbg Then Debug.Print "o : " & o
' check use-frequency against modeled frequency
If o < tEle.Freq(tElement) Then
If dbg Then Debug.Print "Proceed with " & tEle.Name
lBool = True
Else
lBool = False
End If
End If
If dbg Then Debug.Print "----------"
lCounter = lCounter + 1
Loop While (Not lBool And lCounter < 1000)
tEle.IncrementUsed
res = res + tEle.Name
previousRes = tEle.Name
Next j
' Generate results
Debug.Print "INPUT : " & inputString
Debug.Print "RESULT: " & res
EndForSomeReason:
End Sub
Function Rand1To100() As Long
Dim r As Long
Randomize
r = ((100 - 1) * Rnd + 1)
r = Round(r, 0)
Rand1To100 = r
End Function
Private Sub TestSort()
Dim v(1 To 4, 1 To 2) As String
v(1, 1) = "A"
v(1, 2) = "6"
v(2, 1) = "B"
v(2, 2) = "2"
v(3, 1) = "C"
v(3, 2) = "2"
v(4, 1) = "D"
v(4, 2) = "4"
Call NonRepeatSort(v)
End Sub
And you'll need this class module:
' * Class module named Element
Private pName As String
Private pTotal As Long
Private pUsed As Long
Private FrequencyCoefficient As Long ' Obsolete?
' Name
Public Property Get Name() As String
Name = pName
End Property
Public Property Let SetName(s As String)
pName = s
End Property
' Total
Public Property Get Total() As Long
Total = pTotal
End Property
Public Property Let SetTotal(t As Long)
pTotal = t
End Property
' Used
Public Property Get Used() As Long
Used = pUsed
End Property
Public Sub IncrementUsed()
pUsed = pUsed + 1
End Sub
' Freq coefficient
Public Property Get Freq(f As Long) As Double
' Where f is the total number of elements
'Freq = FrequencyCoefficient
Freq = Round((Me.Total / f) * 100, 5)
End Property
Private Property Let SetFreq(f As Long)
' Obsolete?
' Where f is the total number of elements
FrequencyCoefficient = Round((Me.Total / f) * 100)
End Property
' Used freq - internal
Public Property Get UsedFreqI() As Long
If Me.Used > 0 Then
UsedFreqI = Round((Me.Used / Me.Total) * 100)
'Debug.Print "UF: " & UsedFreqI
Else
UsedFreqI = 0
End If
End Property
' Used freq - external
Public Property Get UsedFreqE(f As Long) As Long
If Me.Used > 0 Then
UsedFreq = Round((Me.Used / f) * 100)
Else
UsedFreq = 0
End If
End Property

Repeating msgbox

I've created 3 combobox as below which are to generate results from a listbox. I would like to generate an error box if any of the 3 comboboxes are left empty. However, the code I wrote generates multiple error msg boxes. How do I fix this so msgbox only appears once?
Private Sub Generateresults_Click()
Dim x As Integer
Dim i As Integer
Dim j As Integer
Dim p As Integer
p = Sheets("Training1A").UsedRange.Rows.Count
Sheets("Results").Range("A2:P" & p).ClearContents
x = 2
For i = 0 To Me.Listtest.ListCount - 1
If Me.Searchoption = "AND" Then
If Me.Listtest.Column(1, i) = Search1 And Me.Listtest.Column(2, i) = Search2 Then
For j = 0 To 9
Sheets("results").Cells(x, j + 1) = Me.Listtest.Column(j, i)
Next j
x = x + 1
Else
x = x
End If
ElseIf Me.Searchoption = "OR" Then
If Me.Listtest.Column(1, i) = Search1 Or Me.Listtest.Column(2, i) = Search2 Then
For j = 0 To 9
Sheets("results").Cells(x, j + 1) = Me.Listtest.Column(j, i)
Next j
x = x + 1
Else
x = x
End If
ElseIf Me.Searchoption = "ALL" Then
For j = 0 To 9
Sheets("results").Cells(x, j + 1) = Me.Listtest.Column(j, i)
Next j
x = x + 1
Else
x = x
**If Searchoption = "" Or Search1 = "" Or Search2 = "" Then
MsgBox "Select an option"
End If**
End If
Next i
End Sub
If you want to bail out after dispaying the first MsgBox, put Exit Sub under it.
If Searchoption = "" Or Search1 = "" Or Search2 = "" Then
MsgBox "Select an option"
Exit Sub
End If
Otherwise, the MsgBox call being inside the For...Next loop body, it will be repeated for every iteration that satisfies the conditions.
If you need to run more code between Next and End Sub regardless of whether the MsgBox was shown or not, then you can also Exit For, to exit the loop but remain inside the procedure:
If Searchoption = "" Or Search1 = "" Or Search2 = "" Then
MsgBox "Select an option"
Exit For
End If

Excel vba How to get combination of the numbers output into excel rows?

I need to find out a way to output the result of all combinations of the numbers into rows ( best if could be in a single row)
I have 8 digits {1,2,3,4,5,6,7,8} the typical output for the combination is i;j (i, j are numbers from the set and i< j) if pick up two. To generate result is simple:
Dim Myarray_2 As String
Dim sht as Worksheet
set sht = Sheet1
Myarray_2 = "" ' pick up 2 out of 8
For j = 2 To 8
For i = 1 To j - 1
sht.Cells(i + 1, j + 1) = Str(MyArray(i)) + ";" + Str(MyArray(j))
Myarray_2 = Myarray_2 + Str(MyArray(i)) + ";" + Str(MyArray(j)) + "|"
Next i
Next j
This is an example for pick up 2, I already have it output to rows of a worksheet.
I also have solution for picking up 3, now my questions is for the rest of the cases, how to get the out put?
Here is the solution for picking up 3:
Dim Myarray_3 As String
Myarray_3 = "" ' 3 out of 8
k = 3
Do While k >= 3 And k <= 8
'inner loop through i j
For j = 2 To k - 1
For i = 1 To j - 1
sht.Cells(i + 11, j - 1 + m) = Str(MyArray(i)) + ";" + Str(MyArray(j)) + ";" + Str(MyArray(k))
Myarray_3 = Myarray_3 + Str(MyArray(i)) + ";" + Str(MyArray(j)) + ";" + Str(MyArray(k)) + "|"
Next i
Next j
k = k + 1
m = m + 7
Loop
By the way the MyArray(i) is initialized as Myarray(i) = i
I found some code that I got from another good programmer, I changed the code to fit to your problem. If you have N as the number of members of your set/array, then you will have (2^N)-1 combinations, however you can filter them using your own conditions. Note that in your problem, the order of the members would be important when it comes to filtration using your condition.
The code will first generate ALL OF THE COMBINATIONS and then apply the conditions. Array Result would be the main output so its size will be always (2^N)-1. Array Result-filtered will be what you want.
Note that if you have the numbers sorted from left to right, arrays Result and Result_filtered will be the same.
You can print the out put with any format you like into any sheet.
This method uses bitwise calculation to get the combinations:
if N=2, then number of comnibations would be (2^2)-1=3
we always exclude 0 'in binary of course
{A,B} -> { [00],[01],[10],[11] } ->{ ignore, [B],[A],[AB]}
I hope this helps! if it did, please hit the checkmark to this anwer
Run Sub Test:
Sub Test()
Dim bCondSatisfied As Boolean
Dim InxComb As Integer
Dim InxResult As Integer
Dim count As Integer
Dim i As Integer
Dim j As Integer
Dim arr() As String
Dim TestData() As Variant
Dim Result() As Variant
Dim Result_filtered() As Variant
TestData = Array(1, 3, 2, 4)
Call GenerateCombinations(TestData, Result)
'Now you have all the possible combinations, you can apply custom conditions
'(e.g. any number on the left side of another number should be smaller, practically this is satisfied with the
' given test array, but if the numbers are scrambled it will fix the problem)
ReDim Result_filtered(0 To 0)
Result_filtered(0) = "No Combination Matched the Condition" 'default for the case there is no result matched
count = 0
For i = 0 To UBound(Result)
arr() = Result(i)
bCondSatisfied = True
If UBound(arr) > 0 Then 'if there is more than one number in the array, compare the adjacent numbers
For j = 0 To UBound(arr) - 1
If arr(j) > arr(j + 1) Then
bCondSatisfied = False
Exit For
End If
Next j
End If
'Store the array in the filtered array if it passed the test
If bCondSatisfied = True Then
ReDim Preserve Result_filtered(count)
Result_filtered(count) = arr
count = count + 1
End If
Next i
'Print Result
For InxResult = 0 To UBound(Result)
Debug.Print Right(" " & InxResult + 1, 3) & " ";
For InxComb = 0 To UBound(Result(InxResult))
Debug.Print "[" & Result(InxResult)(InxComb) & "] ";
Next
Debug.Print
Next
Debug.Print "-----------------" 'separate two results
'Print Result_filtered
For InxResult = 0 To UBound(Result_filtered)
Debug.Print Right(" " & InxResult + 1, 3) & " ";
For InxComb = 0 To UBound(Result_filtered(InxResult))
Debug.Print "[" & Result_filtered(InxResult)(InxComb) & "] ";
Next
Debug.Print
Next
End Sub
Sub GenerateCombinations(ByRef AllFields() As Variant, _
ByRef Result() As Variant)
Dim InxResultCrnt As Integer
Dim InxField As Integer
Dim InxResult As Integer
Dim i As Integer
Dim NumFields As Integer
Dim Powers() As Integer
Dim ResultCrnt() As String
NumFields = UBound(AllFields) - LBound(AllFields) + 1
ReDim Result(0 To 2 ^ NumFields - 2) ' one entry per combination
ReDim Powers(0 To NumFields - 1) ' one entry per field name
' Generate powers used for extracting bits from InxResult
For InxField = 0 To NumFields - 1
Powers(InxField) = 2 ^ InxField
Next
For InxResult = 0 To 2 ^ NumFields - 2
' Size ResultCrnt to the max number of fields per combination
' Build this loop's combination in ResultCrnt
ReDim ResultCrnt(0 To NumFields - 1)
InxResultCrnt = -1
For InxField = 0 To NumFields - 1
If ((InxResult + 1) And Powers(InxField)) <> 0 Then
' This field required in this combination
InxResultCrnt = InxResultCrnt + 1
ResultCrnt(InxResultCrnt) = AllFields(InxField)
End If
Next
' Discard unused trailing entries
ReDim Preserve ResultCrnt(0 To InxResultCrnt)
' Store this loop's combination in return array
Result(InxResult) = ResultCrnt
Next
End Sub

Excel: Split ; separated cell values into columns and then shift in consecutive rows

I'm in the situation described by fig.1 where I have a cell with the reference name and a cell with one or more semicolon separated emails associated to the same reference. I'd like to split the cells contaning more than one email stacking them consecutively and copying the refence name. Is it possible to do this with a VBA Macro in Excel 2007? I know the existence of the "Split in columns" command, but I don't know how to automatically shift the columns in rows and copying the reference name. Thanks in advance.
Here you go:
Sub SplitColumnB()
Dim r As Range
Set r = [B2]
Do While r.Value <> ""
res = Split(r.Value, " ; ")
i = 0
For Each resStr In res
If i > 0 Then r.Offset(1).EntireRow.Insert xlDown
r.Offset(IIf(i > 0, 1, 0)).Value = resStr
r.Offset(IIf(i > 0, 1, 0), -1).Value = Right(resStr, Len(resStr) - InStr(resStr, "#"))
i = i + 1
Next
Set r = r.Offset(IIf(i > 0, i, 1))
Loop
End Sub
Try with the below code. Replace all instances of Sheet1 with the name of your worksheet.
Sub test()
Dim Ref As String
Dim Eid As String
Dim RefR()
Dim EidR()
Rcnt = Sheets("Sheet1").Range("A65000").End(xlUp).Row
K = 0
L = 0
For i = 2 To Rcnt
Ref = Sheets("Sheet1").Range("A" & i).Value
Temp = Split(Sheets("Sheet1").Range("B" & i).Value, ";")
K = K + 1
ReDim Preserve RefR(1 To K)
RefR(K) = Ref
For j = LBound(Temp) To UBound(Temp)
If L <= UBound(Temp) Then
ReDim Preserve EidR(Rcnt, L)
L = UBound(Temp)
End If
EidR(K, j) = Temp(j)
Next j
Next i
RowValue = 2
For i = 1 To UBound(RefR)
For j = 0 To L
Sheets("Sheet1").Range("A" & RowValue).Value = RefR(i)
Sheets("Sheet1").Range("B" & RowValue).Value = Trim(EidR(i, j))
RowValue = RowValue + 1
Next j
Next i
End Sub