Using Or / And in Do While - vb.net

I'm trying to create a solution where I push a button and two random numbers appear, that are divisible and leave no remainder. Below is the following code;
Dim E1 As Integer = CInt(Int((11 * Rnd()) + 1)) 'Random number between 1 and 10
Dim E2 As Integer = CInt(Int((11 * Rnd()) + 1)) 'Random number between 1 and 10
Do While E1 Mod 2 <> 0
E1 = CInt(Int((11 * Rnd()) + 1))
Loop
Do While E1 Mod E2 <> 0 And _
E2 <> 1 And _
E2 <> 0 And _
E1 <> E2
E2 = CInt(Int((11 * Rnd()) + 1))
Loop
lstDivVar1.Items.Add(E1)
lstDivVar2.Items.Add(E2)
The plan is to make a question that a student can answer - by being asked to divide E1 by E2. However, I don't want E2 to have (in chronological order to the Do While statement for E2);
(1) To be a number that causes a remainder
(2) To be 1
(3) To be 0
(4) To be the same number as E1
These are for obvious mathematical reasons to provide questions that challenge the students more.
Unfortunately, only the first logic in my Do While for E2 is being applied (E1 Mod E2 <> 0)
Any suggestions how to apply multiple conditions to a loop - it's a mickey mouse mistake I'm sure but I can't find the answer online - so please answer kindly :)
Hugh

You just had your logic wrong. This should work for you.
Do While E1 < 4 OrElse E1 Mod 2 <> 0
E1 = CInt(Int((11 * Rnd()) + 1))
Loop
Do While E1 Mod E2 <> 0 OrElse _
E2 = 1 OrElse _
E2 = 0 OrElse _
E1 = E2
E2 = CInt(Int((11 * Rnd()) + 1))
Loop

Related

Exit 2 For loop when condition is met in a 3 For loop nested system in VBA

I am trying to write a code which has multiple For and If loops. I will try to explain the problem first where the dataset I have is like the following in column 'AH':
0,0,0,0,1,1,2,2,2,2,2,2,1,1,1,0,0,0,0,0,2,2,2,2,2,0,0,..... where the number of 0s, 1s and 2s in a stretch is unknown. What I am trying to find the number of cycles, where a cycle is defined when there has to be atleast 3 0s in a stretch and then has to be atleast 4 2s consecutively. So, to do that, I wrote the code in the following format
Dim M As Single: Dim Count As Integer: Dim A As Integer: Dim B As Integer
M = 2: Count = 0: A =3: B=4
Dim temp As Integer: Dim temp1 As Integer: temp = 0
For L = M To 50
Sheets("Sheet1").Range("AJ" & M) = M
temp = 0
For L1 = L To L + A
temp = temp + Sheets("Sheet1").Range("AH" & L1)
Next L1
If temp = 0 Then
N = L + A
For N1 = N To 60
If Sheets("Sheet1").Range("AH" & N1) = 2 Then
temp1 = 0
For I1 = N1 To N1 + B
temp1 = temp1 + Sheets("Sheet1").Range("AH" & I1)
Next I1
If temp1 = 2 * B Then
flg = True
Exit For
End If
End If
Next N1
Count = Count + 1: M = I1
Sheets("Sheet1").Range("AJ2") = Count
If flg = True Then Exit For
End If
M = M + 1
Next L
Basically, what I am trying to do is find the first 0 and count the sum of 3 consecutive values. If it is 0, then I am searching for 2. When the first 2 is found, it will add up the next 4 terms and if the sum is equal to 2*4, then I will update the count and the code should start look for 0. However, using the 'Exit For' puts me out of all the loops. And if I don't put Exit, then it keep counting the 2s for more times. I am new to VBA and struck with this problem for a long time. Any help on this will be greatly appreciated. Thank you in advance.

Exit Do look in nested For loop break all loops

I am new to VBA and getting stuck with a small piece of code which I think I am missing something very easy. I have a column of 0,1 and 2 and trying to calculate the transitions from 0 to 2 and then back to 0 when 0 appears for consecutively atleast A times and 2 appears for consecutive B times. After putting the For and IF loops, I want to exit the Do loop so that it does not get over counted. However putting the Exit Do shows compilation error and shows all the End If and Next statement as an error. I am totally confused why that is happening and any help on it will be greatly appreciated. Thank you
For L = M To lastrow - A
temp = 0
For L1 = L To L + A
temp = temp + Sheets("Sheet1").Range("AH" & L1)
Next L1
If temp = 0 Then
N = L + A: A_start = N: x_start = x_start + 1
For N1 = N To 50 'lastrow - B
If Sheets("Sheet1").Range("AH" & N1) = 2 Then
temp1 = 0
For I1 = N1 To N1 + B
temp1 = temp1 + Sheets("Sheet1").Range("AH" & I1)
Next I1
Do While temp1 = 2 * B
Count = Count + 1: M = I1: B_start = I1: x_Stop = x_Stop + 1
Sheets("Sheet1").Range("AN2") = Count
Exit Do
End If
Next N1
End If
Next L

Why on my code that checks for permutations, Characters also permute with themselves?

So my code searches for permutations from a random given String, and checks some .txt dictionary files (which are loaded in arrays) to see the words that can be made with the random given letters. But my code also makes them permute with themselves. For instance if i put "ab" it should make these permutations "ab" and "ba". INstead it makes "aa", "ab", "ba" and "bb". Any ideas? (the given code is for words until length 3)
If TextBox1.Text.Length > 1 Then
For Each c0 As Char In chars
For Each c1 As Char In chars
For i As Integer = 0 To Rank2.Length - 1
test = Rank2(i)
If InStr(Rank2(i), c0 & c1) Then
RankBox2.Items.Add(test)
End If
Next
Next
Next
End If
If TextBox1.Text.Length > 2 Then
For Each c0 As Char In chars
For Each c1 As Char In chars
For Each c2 As Char In chars
For i As Integer = 0 To Rank3.Length - 1
test = Rank3(i)
If InStr(Rank3(i), c0 & c1 & c2) Then
RankBox3.Items.Add(test)
End If
Next
Next
Next
Next
End If
If TextBox1.Text.Length > 3 Then
For Each c0 As Char In chars
For Each c1 As Char In chars
For Each c2 As Char In chars
For Each c3 As Char In chars
For i As Integer = 0 To Rank4.Length - 1
test = Rank4(i)
If InStr(Rank4(i), c0 & c1 & c2 & c3) Then
RankBox4.Items.Add(test)
End If
Next
Next
Next
Next
Next
End If
If the goal is exclude the arrangement of characters that repeat themselves, then you would need to add a check before processing the code inside the for loops.
For example..
If TextBox1.Text.Length > 1 Then
For Each c0 As Char In chars
For Each c1 As Char In chars
If c0 <> c1 Then
For i As Integer = 0 To Rank2.Length - 1
test = Rank2(i)
If InStr(Rank2(i), c0 & c1) Then
RankBox2.Items.Add(test)
End If
Next
End If
Next
Next
End If
Same solution as #RyanRoos, but with indexes. So the compare is with the indexes.
Dim c0 As Char
Dim c1 As Char
If TextBox1.Text.Length > 1 Then
For i = 0 to chars.Length - 1
For j = 0 to chars.Length - 1
If i <> j Then
For k As Integer = 0 To Rank2.Length - 1
test = Rank2(k)
If InStr(Rank2(k), c0 & c1) Then
RankBox2.Items.Add(test)
End If
Next
End If
Next
Next
End If
So if you have ab, it will produce ab and ba
If you have aba, it will produce aab, aba, baa twice each, because the a at first pos has been permuted with a at third pos.

VBA - Recognize typos in email domain

I'm working on a VBA script that is to work through an extensive list of email addresses and flag the ones that are suspected of being wrong.
I'd like to refine the routine by adding a function that would spot typos in common domain names such as gmail, hotmail, msn, skynet, etc. I'll have a list of these common display names in an array.
The string function would see if the inputted string looks similar but is not the same as an element in the array, and return true as boolean if it is the case.
Idea is to spot erroneous entries such as: homtail, mns, slynet, hotmal, yahooo, etc.
Not looking for a script per se, looking for inspiration of how to tackle this problem...
a fuzzy comarison is what you need - there is code here that will compare two strings, and give you a score from 0 to 1 depending on how close they are. It will be up to you to decide how close they are to do automatic substitution.
example results:
server text fuzzy score
------- -------- -----------
hotmail hotmale 0.7619048
hotmail hot 0.4285714
hotmail notmail 0.8571429
hotmail NotEvenClose 0.1944444
hotmail hotmail 1
hotmail yellow 0.0952381
hotmail homtail 0.7142857
The the source code has been released under GNU Lesser GPL
in case of link rot, here's the code:
Public Function Fuzzy(ByVal s1 As String, ByVal s2 As String) As Single
Dim i As Integer, j As Integer, k As Integer, d1 As Integer, d2 As Integer, p As Integer
Dim c As String, a1 As String, a2 As String, f As Single, o As Single, w As Single
'
' ******* INPUT STRINGS CLEANSING *******
'
s1 = UCase(s1) 'input strings are converted to uppercase
d1 = Len(s1)
j = 1
For i = 1 To d1
c = Mid(s1, i, 1)
Select Case c
Case "0" To "9", "A" To "Z" 'filter the allowable characters
a1 = a1 & c 'a1 is what remains from s1 after filtering
j = j + 1
End Select
Next
If j = 1 Then Exit Function 'if s1 is empty after filtering
d1 = j - 1
s2 = UCase(s2)
d2 = Len(s2)
j = 1
For i = 1 To d2
c = Mid(s2, i, 1)
Select Case c
Case "0" To "9", "A" To "Z"
a2 = a2 & c
j = j + 1
End Select
Next
If j = 1 Then Exit Function
d2 = j - 1
k = d1
If d2 < d1 Then 'to prevent doubling the code below s1 must be made the shortest string,
'so we swap the variables
k = d2
d2 = d1
d1 = k
s1 = a2
s2 = a1
a1 = s1
a2 = s2
Else
s1 = a1
s2 = a2
End If
If k = 1 Then 'degenerate case, where the shortest string is just one character
If InStr(1, s2, s1, vbBinaryCompare) > 0 Then
Fuzzy = 1 / d2
Else
Fuzzy = 0
End If
Else '******* MAIN LOGIC HERE *******
i = 1
f = 0
o = 0
Do 'count the identical characters in s1 and s2 ("frequency analysis")
p = InStr(1, s2, Mid(s1, i, 1), vbBinaryCompare)
'search the character at position i from s1 in s2
If p > 0 Then 'found a matching character, at position p in s2
f = f + 1 'increment the frequency counter
s2 = Left(s2, p - 1) & "~" & Mid(s2, p + 1)
'replace the found character with one outside the allowable list
'(I used tilde here), to prevent re-finding
Do 'check the order of characters
If i >= k Then Exit Do 'no more characters to search
If Mid(s2, p + 1, 1) = Mid(s1, i + 1, 1) Then
'test if the next character is the same in the two strings
f = f + 1 'increment the frequency counter
o = o + 1 'increment the order counter
i = i + 1
p = p + 1
Else
Exit Do
End If
Loop
End If
If i >= k Then Exit Do
i = i + 1
Loop
If o > 0 Then o = o + 1 'if we got at least one match, adjust the order counter
'because two characters are required to define "order"
finish:
w = 2 'Weight of characters order match against characters frequency match;
'feel free to experiment, to get best matching results with your data.
'If only frequency is important, you can get rid of the second Do...Loop
'to significantly accelerate the code.
'By altering a bit the code above and the equation below you may get rid
'of the frequency parameter, since the order counter increments only for
'identical characters which are in the same order.
'However, I usually keep both parameters, since they offer maximum flexibility
'with a variety of data, and both should be maintained for this project
Fuzzy = (w * o + f) / (w + 1) / d2
End If
End Function
What you want to do is called Hamming codes (or hamming distance) -
try this

What could be slowing down my Excel VBA Macro?

This function goes through all integers and picks out binary values with only five ones and writes them to the spreadsheet.
To run this For x = 1 To 134217728 would take 2.5 days!!!! Help!
How could I speed this up?
Function D2B(ByVal n As Long) As String
n = Abs(n)
D2B = ""
Do While n > 0
If n = (n \ 2) * 2 Then
D2B = "0" & D2B
Else
D2B = "1" & D2B
n = n - 1
End If
n = n / 2
Loop
End Function
Sub mixtures()
Dim x As Long
Dim y As Integer
Dim fill As String
Dim mask As String
Dim RowOffset As Integer
Dim t As Date
t = Now
fill = ""
For x = 1 To 134217728
mask = Right(fill & CStr(D2B(x)), Len(fill & CStr(D2B(x))))
Debug.Print mask
If x > 100000 Then Exit For
If Len(mask) - Len(WorksheetFunction.Substitute(mask, "1", "")) = 5 Then _
RowOffset = RowOffset + 1
For y = 1 To Len(mask)
If Len(mask) - Len(WorksheetFunction.Substitute(mask, "1", "")) = 5 Then _
Range("mix").Offset(RowOffset).Cells(y) = Mid(mask, y, 1)
Next
Next
Debug.Print DateDiff("s", Now, t)
End Sub
By first sight guess, I think the problem lies in the fact that you do that cell by cell, which causes many read and write accesses.
You should do it range by range, like
vArr = Range("A1:C1000").Value
' it is array now, do something here effeciently
Range("A1:C1000").Value = vArr
You want find all 28bit numbers with 5 1s
There are 28*27*26*25*24/5/4/3/2=98280 such numbers
The following code took ~10 seconds on my PC:
lineno = 1
For b1 = 0 To 27
For b2 = b1 + 1 To 27
For b3 = b2 + 1 To 27
For b4 = b3 + 1 To 27
For b5 = b4 + 1 To 27
Cells(lineno, 1) = 2 ^ b1 + 2 ^ b2 + 2 ^ b3 + 2 ^ b4 + 2 ^ b5
lineno = lineno + 1
Next
Next
Next
Next
Next
mask = Right(fill & CStr(D2B(x)), Len(fill & CStr(D2B(x))))
The above line of code does the same thing (CStr(D2B(x))) twice.
Store the result of CStr(D2B(x)) in a variable & use that variable in the above line of code.
I've got 2 suggestions:
Get rid of the substitution command by counting the ones/zeroes in D2B and return an empty string if the count does not equal 5
Write these pre-filtered bitstrings to an array first and copy the array directly to the cells when finished.
Something like
ws.Range(ws.cells(1, 1), ws.cells(UBound(dstArr, 1) + 1, UBound(dstArr, 2) + 1)) = dstArr
The array-copy-trick greatly improves performance!