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.
Related
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
Found a function on Excelguru which I changed a few things in and gonna edit some more. The idea is to use this to register worked hours and minutes.
There is one thing in this I don't understand: if I type the wrong time in the column reff I get a msg that its wrong, but it wont disappear unless I click it 10 times. I cant see what Im doing wrong. The entire code is posted and Im grateful for any help.
Use his function as part of the formula in the sheet like: TimeValue($E2;$F2;"16:00";"18:00";B2;9;C2)
Function TimeValue(FromTime As String, ToTime As String, StartTime As String, StopTime As String, Optional Weekday As String, Optional Daynr As Integer, Optional Holiday As String)
Dim x As Long
Dim F As Double
Dim T As Double
Dim Start As Double
Dim Stopp As Double
Dim Min As Long
Dim Day As Integer
Dim OverMid As Boolean
Select Case LCase(Weekday)
Case "mandag"
Day = 1
Case "tirsdag"
Day = 2
Case "onsdag"
Day = 3
Case "torsdag"
Day = 4
Case "fredag"
Day = 5
Case "lordag"
Day = 6
Case "sondag"
Day = 7
Case "x"
Day = 8
Case Else
Day = 0
End Select
OverMid = False
If LCase(Holiday) = "x" Then Day = 8
If Len(FromTime) = 0 Or Len(ToTime) = 0 Then
Exit Function
End If
If Len(FromTime) <> 5 Then
MsgBox ("Use format TT:MM - From time is wrong:" & FromTime)
Exit Function
End If
If Len(ToTime) <> 5 Then
MsgBox ("Use format TT:MM - To time is wrong:" & ToTime)
Exit Function
End If
F = Val(Left(FromTime, 2)) * 60 + Val(Right(FromTime, 2))
T = Val(Left(ToTime, 2)) * 60 + Val(Right(ToTime, 2))
Start = Val(Left(StartTime, 2)) * 60 + Val(Right(StartTime, 2))
Stopp = Val(Left(StopTime, 2)) * 60 + Val(Right(StopTime, 2))
If T = 0 Then T = 24 * 60
If T < F Then
T = T + 24 * 60
OverMid = True
End If
If Stopp = 0 Then Stopp = 24 * 60
For x = F + 1 To T
If x > Start And x <= Stopp Then
Min = Min + 1
End If
Next x
If OverMid = True Then
For x = 0 To Val(Left(ToTime, 2)) * 60 + Val(Right(ToTime, 2))
If x > Start And x <= Stopp Then
Min = Min + 1
End If
Next x
End If
'If weekday is set, equal to day
If Daynr <> 0 Then
If Daynr <> 9 Then
If Day <> Daynr Then Min = 0
End If
If Daynr = 9 And (Day > 5) Then
Min = 0
End If
End If
TimeValue = Min / 60
End Function
And the sub in the sheets
Private Sub Worksheet_Change(ByVal Target As Range)
Dim streng As String
Dim k As Long
Dim r As Long
k = Target.Column
r = Target.Row
If Cells(1, k) = "P" Then
If Cells(r, k) = "x" Then
Cells(r, 4) = "x"
Else
Cells(r, 4) = ""
End If
End If
End Sub
Message boxes really don't belong in UDFs (VBA functions meant to be used as spreadsheet functions).
Instead of the message box you could use code like:
If Len(FromTime) <> 5 Then
TimeValue = "Error! Use format TT:MM - From time is wrong:" & FromTime
Exit Function
Or perhaps:
If Len(FromTime) <> 5 Then
TimeValue = CVErr(xlErrValue)
Exit Function
This later will cause #VALUE! to display in the cell. Include enough documentation in your spreadsheet so that users can interpret such error values.
I'm creating a connect four game and I'm having some trouble with the horizontal loop. The loop below works and it's for a vertical win. I have a two labels for each row and two labels for each column one for the color blue and one for the color red. When I add in my other labels I cant seem to find where I take the step-1 in order to change labels and go upwards with the next label. I have also tried adding a whole new loop below that just dedicated to the horizontal winnings.
For i = 5 To 0 Step -1`
If board(i, 0) = 0 Then
board(i, 0) = pturn
If pturn = 1 Then
Labelboard(i, 0).BackColor = Color.Red
CounterB = 0
lblcounterBlue.Text = "Matches = " & CounterB
CounterR = CounterR + 1
lblCounterRed.Text = "Matches = " & CounterR
ElseIf pturn = 2 Then
Labelboard(i, 0).BackColor = Color.Blue
CounterR = 0
lblCounterRed.Text = "Matches = " & CounterR
CounterB = CounterB + 1
lblcounterBlue.Text = "Matches = " & CounterB
End If
pturn = pturn + 1
If pturn = 3 Then pturn = 1
If CounterR = 4 Then
MsgBox("Game Over")
End If
If CounterB = 4 Then
MsgBox("Game Over")
End If
Exit Sub
End If
Next
I don't quite understand your setup, but hopefully this will get you close enough for you to get things working. I'm having to make a few assumptions, but I've tried to declare a constant each time I have to make the code more readable and easier for you to adapt to what you've already written.
What I've written is a function that lets you know if a specific space is part of winning streak. It assumes board() is public. If pturn is also public, you could make this even more efficient as long as you call it every turn, as noted in the comments. If you know which space was the last one played, you can maximize efficiency by only calling the function for that space (assuming you call it at the end of every player turn). If you don't know which space was played last, you can loop through every space in board() and test each one.
Function winner(rowNum As Integer, colNum As Integer) As Integer
'Returns 0 if space does not create a win, or the winning player number if it does
'Change to winner(...) As Boolean <--To only test current player
Dim minRow As Integer = LBound(board, 0)
Dim maxRow As Integer = UBound(board, 0)
Dim minColumn As Integer = LBound(board, 1)
Dim maxColumn As Integer = UBound(board, 1)
'These are the values I assume are in board()
'(I don't actually use them in the code)
Const emptySpace As Integer = 0
Const red As Integer = 1
Const blue As Integer = 2
Dim player As Integer
Dim streak As Integer
Dim r As Integer, c As Integer 'loop placeholders
Dim v As Integer, h As Integer 'control search direction
For v = 0 To 1
For h = -1 To 1
If v = 1 Or h = 1 Then
'These loops and test check each direction (vertical, horizontal and
'both diagonals) for a win exactly once.
player = board(rowNum, colNum)
If player > 0 Then 'If player = pturn <-- to only check current player
streak = 1
'check positive direction
r = rowNum + h
c = colNum + v
Do While r >= minRow And r <= maxRow And c >= minColumn And c <= maxColumn
If board(r, c) = player Then
streak = streak + 1
If streak = 4 Then
Return player 'True <--If testing only current player
Else
r = r + h
c = c + v
End If
Else
Exit Do
End If
Loop
'check negative direction
r = rowNum - h
c = colNum - v
Do While r >= minRow And r <= maxRow And c >= minColumn And c <= maxColumn
If board(r, c) = player Then
streak = streak + 1
If streak = 4 Then
Return player 'True <--If testing only current player
Else
r = r - h
c = c - v
End If
Else
Exit Do
End If
Loop
End If
End If
Next h
Next v
Return 0 'Function has completed and no winner was found
'Return False <-- If only testing current player
End Function
I am new to VBA. I am trying to run a formatting check on a sheet.
The error is Next without For error. What I am trying to do is to check columns H and O from rows number 33 to 58 for number formatting error. It shows error at "Next n".
The code is like this:
Public Sub PercentageCheck()
Dim CTRYname As String
Dim x As Integer
Dim n As Integer
Dim m As Integer
For n = 1 To 13
CTRYname = ThisWorkbook.Sheets("Country lookup").Range("A1").Offset(n, 0).Value
For m = 33 To 58
For x = 8 To 15
If x = 9 Or x = 10 Or x = 11 Or x = 12 Or x = 13 Or x = 14 Then
GoTo Names
Else
wkbCurr.Sheets(CTRYname).Activate
If IsNumeric(wkbCurr.Sheets(CTRYname).Cells(x, m).Value) Then
If wkbCurr.Sheets(CTRYname).Cells(x, m).Value > 9.99 Then
wkbCurr.Sheets(CTRYname).Cells(x, m).Value = ">999%"
ElseIf wkbCurr.Sheets(CTRYname).Cells(x, m).Value < -9.99 Then
wkbCurr.Sheets(CTRYname).Cells(x, m).Value = "<-999%"
End If
End If
Names:
Next x
Next m
Next n
End Sub
Can you help with suggestions for a better way to check it.
Second question first: suggest a better way to check it.
Answer: be diligent with indenting. This easily revleals the missing line of code
Public Sub PercentageCheck()
Dim CTRYname As String
Dim x As Integer
Dim n As Integer
Dim m As Integer
For n = 1 To 13
CTRYname = ThisWorkbook.Sheets("Country lookup").Range("A1").Offset(n, 0).Value
For m = 33 To 58
For x = 8 To 15
If x = 9 Or x = 10 Or x = 11 Or x = 12 Or x = 13 Or x = 14 Then
GoTo Names
Else
wkbCurr.Sheets(CTRYname).Activate
If IsNumeric(wkbCurr.Sheets(CTRYname).Cells(x, m).Value) Then
If wkbCurr.Sheets(CTRYname).Cells(x, m).Value > 9.99 Then
wkbCurr.Sheets(CTRYname).Cells(x, m).Value = ">999%"
ElseIf wkbCurr.Sheets(CTRYname).Cells(x, m).Value < -9.99 Then
wkbCurr.Sheets(CTRYname).Cells(x, m).Value = "<-999%"
End If
End If
' ---> Missing End If
Names:
Next x
Next m
Next n
End Sub
BTW, the GoTo Names is not necassary in this code. And neither is wkbCurr.Sheets(CTRYname).Activate. Just leave them out and the code works the same.
Update:
Based on your comment and the bug it revealed, I suggest you use more meaningful variable names. This will help avoid this kind of error. Also, prudent use of With can make your code more readable (and faster)
Here's a refactored version to demonstrate
Public Sub PercentageCheck()
Dim CTRYname As String
Dim col As Integer
Dim n As Integer
Dim rw As Integer
For n = 1 To 13
CTRYname = ThisWorkbook.Sheets("Country lookup").Range("A1").Offset(n, 0).Value
With wkbCurr.Sheets(CTRYname)
For rw = 33 To 58
For col = 8 To 15
If col < 9 Or col > 14 Then
With .Cells(rw, col)
If IsNumeric(.Value) Then
If .Value > 9.99 Then
.Value = ">999%"
ElseIf .Value < -9.99 Then
.Value = "<-999%"
End If
End If
End With
End If
Next col, rw
End With
Next n
End Sub
You're missing an END IF for your If x = 9 Or x = 10 Or x = 11 Or x = 12 Or x = 13 Or x = 14 Then ... Else ...
Indent your code to improve readability and this sort of thing will become somewhat self-evident. #chris-neilsen's example is excellent.
Counting opening statements, compared to closing statements will help at a pinch (and is what I did to debug your code in this instance).
Using an IDE that highlights corresponding start/end symbols would also help you (but I'm not sure what IDE's are available for VBA macros... if anything).
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!