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!
Related
I have a set which has an unknown number of objects. I want to associate a label to each one of these objects. Instead of labeling each object with a number I want to label them with letters.
For example the first object would be labeled A the second B and so on.
When I get to Z, the next object would be labeled AA
AZ? then BA, BB, BC.
ZZ? then AAA, AAB, AAC and so on.
I'm working using Mapbasic (similar to VBA), but I can't seem to wrap my head around a dynamic solution. My solution assumes that there will be a max number of objects that the set may or may not exceed.
label = pos1 & pos2
Once pos2 reaches ASCII "Z" then pos1 will be "A" and pos2 will be "A". However, if there is another object after "ZZ" this will fail.
How do I overcome this static solution?
Basically what I needed was a Base 26 Counter. The function takes a parameter like "A" or "AAA" and determines the next letter in the sequence.
Function IncrementAlpha(ByVal alpha As String) As String
Dim N As Integer
Dim num As Integer
Dim str As String
Do While Len(alpha)
num = num * 26 + (Asc(alpha) - Asc("A") + 1)
alpha = Mid$(alpha, 2,1)
Loop
N = num + 1
Do While N > 0
str = Chr$(Asc("A") + (N - 1) Mod 26) & str
N = (N - 1) \ 26
Loop
IncrementAlpha = str
End Function
If we need to convert numbers to a "letter format" where:
1 = A
26 = Z
27 = AA
702 = ZZ
703 = AAA etc
...and it needs to be in Excel VBA, then we're in luck. Excel's columns are "numbered" the same way!
Function numToLetters(num As Integer) As String
numToLetters = Split(Cells(1, num).Address(, 0), "$")(0)
End Function
Pass this function a number between 1 and 16384 and it will return a string between A and XFD.
Edit:
I guess I misread; you're not using Excel. If you're using VBA you should still be able to do this will the help of an reference to an Excel Object Library.
This should get you going in terms of the logic. Haven't tested it completely, but you should be able to work from here.
Public Function GenerateLabel(ByVal Number As Long) As String
Const TOKENS As String = "ZABCDEFGHIJKLMNOPQRSTUVWXY"
Dim i As Long
Dim j As Long
Dim Prev As String
j = 1
Prev = ""
Do While Number > 0
i = (Number Mod 26) + 1
GenerateLabel = Prev & Mid(TOKENS, i, 1)
Number = Number - 26
If j > 0 Then Prev = Mid(TOKENS, j + 1, 1)
j = j + Abs(Number Mod 26 = 0)
Loop
End Function
I previously have a Excel sheet with VBA coding that fills column, row 1 to 10 with the number 1, row 11 to 20 with number 2 and so on. The code I've used is as follows:
Sub fill()
Dim ID
ID = 1
For c = 1 To 34
ActiveWorkbook.Sheets("Sheet1").Cells(c, 1) = ID
ActiveWorkbook.Sheets("Sheet1").Cells(c + 1, 1) = ID
c = c + 1
If (c Mod 10) = 0 Then
ID = ID + 1
End If
Next c
End Sub
Now I want to change it so that the code starts at row 3 onwards. Meaning row 3 to 12 = 1, row 13 to 22 = 2 and so on. So I changed the 'For' statement to:
For c = 3 To 34
But what happens is that the number 1 appears from row 3 to row 10, and then continues with number 2 in row 11 to 20. Not what I was expecting.
Therefore, what would be the best method of changing the code?
If you want exactly the same output but two rows lower, you can use:
Sub fill()
Dim ID
ID = 1
For c = 1 To 34
ActiveWorkbook.Sheets("Sheet1").Cells(c + 2, 1) = ID
ActiveWorkbook.Sheets("Sheet1").Cells(c + 3, 1) = ID
c = c + 1
If (c Mod 10) = 0 Then
ID = ID + 1
End If
Next c
End Sub
If you still only want to go to row 34 but start in row 3, change the 34 to 32 in the above code.
You can also do it without looping and this is easier to adjust the parameters:
Sub fill()
Const NUMBER_OF_ROWS As Long = 34
Const START_ROW As Long = 3
Const ID As Long = 1
Const NUMBER_IN_GROUP As Long = 10
With ActiveWorkbook.Sheets("Sheet1").Cells(START_ROW, 1).Resize(NUMBER_OF_ROWS)
.Value = .Parent.Evaluate("INDEX(INT((ROW(" & .Address & ")-" & START_ROW & ")/" & _
NUMBER_IN_GROUP & ")+" & ID & ",)")
End With
End Sub
When i understand you write, this should work:
You can use the loop how you did at the beginning. and just add plus 2 to c in the ActiveWorkbook.Sheets("Tabelle1").Cells(c + 2, 1) = ID
Sub fill()
Dim ID
ID = 1
For c = 1 To 34
ActiveWorkbook.Sheets("Tabelle1").Cells(c + 2, 1) = ID
ActiveWorkbook.Sheets("Tabelle1").Cells(c + 3, 1) = ID
c= c+1
If (c Mod 10) = 0 Then
ID = ID + 1
End If
Next c
End Sub
something like that should be the simplest way:
Sub fill()
Dim i As Integer
Dim j As Integer
For i = 1 To 4
For j = 1 To 10
ActiveWorkbook.Sheets("Sheet1").Cells(j + (i - 1) * 10 + 2, 1) = i
Next j
Next i
End Sub
EDIT:
No, the simplest way would be type formula into A3:
=ROUNDDOWN(((ROW()-3))/10,0)+1
end drag it donw.
I am getting the "next without for" error. I checked other questions on this and looked for any open if statements or loops in my code, but could find none. I'm need an extra set of eyes to catch my error here.
I am trying to loop through this code and advance the torque value 3 times each times it gets to the 30th i.
'This is Holzer's method for finding the torsional natural frequency
Option Explicit
Sub TorsionalVibrationAnalysis_()
Dim n As Integer 'position along stucture
Dim m As Integer
Dim i As Long 'frequency to be used
Dim j As Variant 'moment of inertia
Dim k As Variant 'stiffness
Dim theta As Long 'angular displacement
Dim torque As ListRow 'torque
Dim lambda As Long 'ListRow 'omega^2
Dim w As Variant
Dim s As Long
'equations relating the displacement and torque
n = 1
Set j = Range("d2:f2").Value 'Range("d2:f2").Value
Set k = Range("d3:f3").Value
'initial value
Set w = Range("B1:B30").Value
For i = 1 To 30
'start at 40 and increment frequency by 20
w = 40 + (i - 1) * 20
lambda = w ^ 2
theta = 1
s = 1
Do While i = 30 & s <= 3
torque = lambda * j(1, s)
s = s + 1
End
m = n + 1
theta = theta - torque(i, n) / k(n)
torque(i, m) = torque(i, n) + lambda * j(m) * theta
If m = 4 & i < 30 Then
w(i) = 40 + (i - 1) * 20
lambda = w(i) ^ 2
ElseIf m = 4 & i >= 30 Then
Cells([d], [5+i]).display (i)
Cells([e], [5+i]).display (theta)
Cells([f], [5+i]).display (torque)
Else
End If
If m <> 4 Then
n = n + 1
End If
Next i
End Sub
You are trying to terminate your While with an End instead of Loop
Try changing your End to Loop in your Do While loop. I think you are terming the loop when you hit that End
Proper indentation makes the problem rather apparent.
You have:
For i = 1 To 30
'...
Do While i = 30 & s <= 3
'...
End
'...
If m = 4 & i < 30 Then
'...
ElseIf m = 4 & i >= 30 Then
'...
Else
End If
If m <> 4 Then
'...
End If
Next i
But run it through Rubberduck's Smart Indenter and you get:
For i = 1 To 30
'...
Do While i = 30 & s <= 3
'...
End
'...
If m = 4 & i < 30 Then
'...
ElseIf m = 4 & i >= 30 Then
'...
Else
End If
If m <> 4 Then
'...
End If
Next i
End Sub
Notice how the End other answers are pointing out, is clearly not delimiting the Do While loop.
The Next i is inside the Do While block, which isn't terminated - when the VBA compiler encounters that Next i, it doesn't know how it could possibly relate to any previously encountered For statement, and thus issues a "Next without For" compile error.
Use an indenter.
j = LBound(arrayTime)
Do Until j = UBound(arrayTime)
j = j + 1
b = b + 1
cnc = b + r
MsgBox cnc
If cnc > 7 Then
b = 0
r = 0
cnc = b + r
End If
numMins = Sheet5.Cells(cnc + 3, 2) - arrayTime(j)
If numMins < 0 Then
g = g + 1
ReArrangeArray arrayTime, j
'ReDim Preserve arrayTime(numrows - 1 + g)
'arrayTime(numrows - 1 + g) = arrayTime(j)
'MsgBox (arrayTime(numrows - 1 + g))
Else
Sheet5.Cells(cnc + 3, 2) = numMins
End If
Loop
If the if statement is true I want to be able to put the array value at the end of the array and remove that value from its current spot. As the code is, it just adds it to the end and increases the size of the array from 12 to 13. How can I get the array to remain size 12 and still place the value at the end of the array and then remove it from its original position? I do not want to touch the array values in front. Just want to take that value and move it to the end.
For instance
array(1,2,3,4,5)
If statement
j on third loop.
array(j)=3
end array should be
array(1,2,4,5,3)
You could use a helper Sub like this one:
Sub ReArrangeArray(inputArray as Variant, indexToSwap as long)
Dim I As Long
Dim tempVal As Variant
If indexToSwap >= LBound(inputArray) And indexToSwap < UBound(inputArray) Then
tempVal = inputArray(indexToSwap)
For I = indexToSwap To UBound(inputArray) - 1
inputArray(i) = inputArray(i + 1)
Next I
InputArray(UBound(inputArray)) = tempVal
End If
End Sub
To be called by your main Sub as follows:
ReArrangeArray arrayTime, j
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