Excel VBA For...Next - vba

I'm a VBA newcomer. I wonder why does sum1() show 10 while sum2() show 11? Thanks in advance.
Sub sum1()
Dim x As Integer
x = 0
For x = 5 To 5
x = x + x
MsgBox x
Next
End Sub
Sub sum2()
Dim x As Integer
x = 0
For x = 5 To 5
x = x + x
Next
MsgBox x
End Sub

A vba for-loop increments the index variable at the end of each iteration. That is what the Next keyword does. In sum1() You get:
Sub sum1()
Dim x As Integer
x = 0 ' x is 0
For x = 5 To 5 ' x set to 5
x = x + x 'x gets 5+5=10
Next 'x gets 10+1=11
MsgBox x 'display x=11
End Sub
but in sum2() you get:
Sub sum2()
Dim x As Integer
x = 0 ' x is 0
For x = 5 To 5 ' x is 5
x = x + x 'x gets 5+5=10
MsgBox x 'display x=10
Next 'x gets 10+1 and is now 11
End Sub
I agree with #MitchWheat, it usually not good practice to modify your index variable while inside a loop. A better approach would be this:
Sub sum3()
Dim x as Integer
Dim i as Integer
x= 1
For i = 5 To 5
x = x + x
Next
MsgBox x
End Sub

For loops increment the loop variable at the end of the loop.
In the second code snippet, the for loop increments x from 10 to 11, and then you display it.
Whereas the first code snippets increments x AFTER you display it. This is not something specific to VBA.
To see this, run:
Sub sum1_1()
Dim x As Integer
x = 0
For x = 5 To 5
x = x + x
MsgBox x
Next
MsgBox x
End Sub
As an aside: It's not best practice to modify loop counters from inside a loop. It can lead to code that is hard to understand.

Related

Excel Userform (VBA) - How to add value in Total if checkbox is checked

I have multiple checkboxes (1 to 8) in Userform (VBA) and their values are mentioned in Ride.Caption (1 to 8). If I check any checkbox, then its value mentioned in Ride should add in Total Value and If I uncheck any checkbox then the value should deduct from the Total Value
As per the below code, I have added all values in Total. But, Checkbox coding is still pending, and I do not know how I can make this code complete. Help me out with your expertise.
Private Sub TotalValue_Click()
Dim X As Double
X = 0
If Len(Ride1.Caption) > 0 Then X = X + Ride1.Caption
If Len(Ride2.Caption) > 0 Then X = X + Ride2.Caption
If Len(Ride3.Caption) > 0 Then X = X + Ride3.Caption
If Len(Ride4.Caption) > 0 Then X = X + Ride4.Caption
If Len(Ride5.Caption) > 0 Then X = X + Ride5.Caption
If Len(Ride6.Caption) > 0 Then X = X + Ride6.Caption
If Len(Ride7.Caption) > 0 Then X = X + Ride7.Caption
If Len(Ride8.Caption) > 0 Then X = X + Ride8.Caption
TotalValue.Caption = X
End Sub
https://ibb.co/7jh7mJh
I check any checkbox, then its value mentioned in Ride should add in Total Value and If I uncheck any checkbox then the value should deduct from the Total Value
You can handle all your checkboxes in a loop. Also you do not need to deduct. Simply recalculate.
Is this what you are trying?
Private Sub CommandButton1_Click()
Dim TotalSum As Double
Dim i As Long
For i = 1 To 8
If Controls("Ride" & i).Value = True Then
TotalSum = TotalSum + Val(Controls("CheckBox" & i).Caption)
End If
Next i
TotalValue.Caption = TotalSum
End Sub
Is this what you're trying?
I've done it in a loop as it's cleaner and easier to handle.
You need to change "CheckBox" to whatever your checkboxes are called.
Private Sub TotalValue_Click()
Dim X As Double, i As Integer
X = 0
For i = 1 To 8
If Me.Controls("CheckBox" & i).Value = True And Len(Me.Controls("Ride" & i).Caption) > 0 Then
X = X + Me.Controls("Ride" & i).Caption
End If
Next i
TotalValue.Caption = X
End Sub
Alternatively, if you want your total to update whenever someone checks/unchecks a checkbox then you can add a change event for each of your textboxes like so:
Private Sub CheckBox1_Change()
If Me.CheckBox1.Value = True Then
Me.TotalValue.Caption = Me.TotalValue.Caption + Val(Me.Ride1.Caption)
Else
Me.TotalValue.Caption = Me.TotalValue.Caption - Val(Me.Ride1.Caption)
End If
End Sub
Again, just change "CheckBox1" to the relevant checkbox name.

Factorial function returning squared number and not factorial

Where is my code wrong? It is returning the square of any number:
Sub factorial()
Dim x As Long, i As Integer, fact As Long
x = InputBox("enter the integer")
For i = 1 To x
fact = i * x
Next i
MsgBox fact
End Sub
Practicing Loops and If Statements!?
Option Explicit
' If you are practicing (loops) then:
Sub factorial()
Dim x As Long, i As Long, fct As Double
x = InputBox("enter the integer")
If x >= 0 And x <= 170 Then
fct = 1
If x > 1 Then
For i = 2 To x
fct = fct * i
Next i
End If
MsgBox fct
Else
MsgBox "Next time enter a number between 0 and 170."
Exit Sub
End If
End Sub
' ...if not, just use Fact
Sub factorialExcel()
Dim x As Long
x = InputBox("enter the integer")
If x >= 0 And x <= 170 Then
MsgBox Application.WorksheetFunction.Fact(x)
Else
MsgBox "Next time enter a number between 0 and 170."
Exit Sub
End If
End Sub
One mistake is that fact needs to be initialized with fact=1 before it is used in the loop. Then inside the loop the result is should be multiplied by the iteration number, as in fact = fact * i. Lastly to make sure you get the highest possible range use the LongLong type (available in VB7 and above) which is a 64-bit integer. Oh, and don't forget to convert the text returned by InputBox to a number type.
Sub factorial()
Dim x As Long, i As Long, fact As LongLong
x = CLng(InputBox("enter the integer"))
fact = 1
For i = 1 To x
fact = fact * i
Next i
MsgBox fact
End Sub
PS. Never use Integer in VBA, but rather opt for the native 32-bit integer Long.
In your code the value of fact is recalculated on any iteration and it is not kept. So at the end, just the last value is shown, which is x*i where i=x, e.g. a square of the input. Something like this, using 90% of your code works:
Sub Factorial()
Dim x As Long, i As Long, fact As Long
x = 5
fact = 1
For i = 1 To x
fact = fact * i
Next i
Debug.Print fact
End Sub

VBA Powerpoint using Model3D : how to refreshing slide

I'm using latest version of Powerpoint on Windows 10.
I'm trying to rotate a 3d model with below code but its not refreshing the screen each time it does a IncrementRotationX
Is there a special function call to get powerpoint to refresh/redraw the 3d object so that it smoothly shows the rotation on screen ? Any help would be appreciated.
Sub Program()
Set myDocument = ActivePresentation.Slides(8)
Dim x As Integer
Dim y As Integer
Dim z As Integer
'Save current position
x = ActivePresentation.Slides(8).Shapes("3D Model 3").Model3D.RotationX
y = ActivePresentation.Slides(8).Shapes("3D Model 3").Model3D.RotationY
z = ActivePresentation.Slides(8).Shapes("3D Model 3").Model3D.RotationZ
MsgBox "RESET Position"
For i = 1 To 45
With myDocument
.Shapes("3D Model 3").Model3D.IncrementRotationX (1)
.Shapes("3D Model 3").Model3D.IncrementRotationY (1)
.Shapes("3D Model 3").Model3D.IncrementRotationZ (1)
End With
Next i
MsgBox "End of routine"
'reset position to starting point
ActivePresentation.Slides(8).Shapes("3D Model 3").Model3D.RotationX = x
ActivePresentation.Slides(8).Shapes("3D Model 3").Model3D.RotationY = y
ActivePresentation.Slides(8).Shapes("3D Model 3").Model3D.RotationZ = z
End Sub
I'm expecting my object to smoothly rotate in the powerpoint slide but it does not. It simply jolts to the last position; its not updating and refreshing to show it rotate as I "IncrementRotationX(1)"
For smooth rotation or animation, it is needed to wait some time between the loops. A possible way is to wait 1 second. (For waiting less than 1 second, see the solutions here - How to give a time delay of less than one second in excel vba?)
Thus, write Wait1Second within the loop:
For i = 1 To 45
With myDocument
.Shapes("3D Model 3").Model3D.IncrementRotationX (1)
.Shapes("3D Model 3").Model3D.IncrementRotationY (1)
.Shapes("3D Model 3").Model3D.IncrementRotationZ (1)
End With
WaitASecond
Next i
This is the sub Wait1Second():
Sub Wait1Second()
Application.Wait (Now + #12:00:01 AM#)
End Sub
And this is a demo in Excel:
The code of the demo:
Option Explicit
Sub TestMe()
Dim cnt As Long
For cnt = 1 To 3
Wait1Second
WriteCircle 15, 1, 1
Wait1Second
WriteCircle 15, 1, 2
Wait1Second
WriteCircle 15, 2, 1
Wait1Second
WriteCircle 15, 2, 2
Next cnt
End Sub
Sub WriteCircle(sizeX As Long, stepX As Long, stepY As Long)
Dim sizeY As Long: sizeY = sizeX
Dim y&, x&, r&, g&, b&
Dim myCell As Range
Worksheets(1).Cells.Clear
For x = 1 To sizeX Step stepX
For y = 1 To sizeY Step stepY
With Worksheets(1)
Set myCell = .Cells(x, y)
If r >= 255 Then
If g >= 255 Then
b = b + 2
Else
g = g + 2
End If
Else
r = r + 2
End If
myCell.Interior.Color = RGB(r, g, b)
End With
Next
Next
End Sub

Item transfer between Listboxes Last Row Issue

I have a listbox with values that I want to move to another listbox so the user can sort the items. When the last item is selected, it only moves that item and erases the values above it. How can I have it function like the other items in the list?
FYI, it is a single item selection, if that changes anything
Option Explicit
Option Base 1
Private Sub Add_Click()
Dim x As Integer, count As Integer
count = Me.Unsorted.ListCount
For x = 0 To count
If Me.Unsorted.Selected(x) = True Then
Me.Sorted.AddItem Me.Unsorted.List(x)
End If
Next x
For x = count To 0 Step -1
If Me.Unsorted.Selected(x) = True Then
Me.Unsorted.RemoveItem x
End If
Next x
End Sub
you could use this
Private Sub Add_Click()
Dim x As Integer
Dim nSelecteds As Long
With Me
With .Unsorted
ReDim selecteds(1 To .ListCount) As Long
For x = .ListCount - 1 To 0 Step -1
If .Selected(x) Then
nSelecteds = nSelecteds + 1
selecteds(nSelecteds) = x
Me.Sorted.AddItem .List(x)
End If
Next x
If nSelecteds > 0 Then
For x = 1 To nSelecteds
.RemoveItem selecteds(x)
Next x
End If
End With
End With
End Sub

Keep a rolling average of a GPA without a div/0 error

Essentially I am saying, start with the average of all 4 semesters, if Sem 4 average is "0" or has a #div/0 error then just take sem 1-3 averages, if Sem 3 avg is 0 or #div/0 then just take sem 1-2 average, etc.
I have got it to a point where I get the error message "unable to get the average property for the worksheet function class."
Sub sem1avg()
If w = 0 Then
Worksheets("Sheet1").Range("H1") = "N/A"
ElseIf w > 0 Then
Application.WorksheetFunction.Average (Range("B2:B10"))
End If
End Sub
Sub sem2avg()
If x = 0 Then
Call sem1avg
ElseIf x > 0 Then
Worksheets("Sheet1").Range.cell(H1) = _
Application.WorksheetFunction.Average(B11, B23)
End If
End Sub
Sub sem3avg()
If y = 0 Then
Call sem2avg
ElseIf y > 0 Then
Worksheets("Sheet1").Range(H1) = _
Application.WorksheetFunction.Average(B11, B23, E11)
End If
End Sub
Sub sem4avg()
Dim w As Long
Dim x As Long
Dim y As Long
Dim z As Long
w = Worksheets("Sheet1").Range("B11")
x = Worksheets("Sheet1").Range("B23")
y = Worksheets("Sheet1").Range("E11")
z = Worksheets("Sheet1").Range("E23")
If z = 0 Then
Call sem3avg
ElseIf z > 0 Then
Worksheets("Sheet1").Range("H1") = _
Application.WorksheetFunction.Average("B11, B23, E11, E23")
End If
End Sub
Of course you could just use the AGGREGATE() Function:
=AGGREGATE(1,6,B11,E11,B23,E23)
The AGGREGATE() Function was introduced in 2010 to deal with this specific problem. The first criteria tells the function we want the average, the second tells the formula to exclude errors. The third is the range.
To deal with the 0 and the Errors this formula will do it:
=SUM(IF(ISNUMBER(B11),B11),IF(ISNUMBER(B23),B23),IF(ISNUMBER(E11),E11),IF(ISNUMBER(E23),E23))/SUM(IF(ISNUMBER(B11),IF(B11>0,1)),IF(ISNUMBER(B23),IF(B23>0,1)),IF(ISNUMBER(E11),IF(E11>0,1)),IF(ISNUMBER(E23),IF(E23>0,1)))
There's more than one thing happening and so far no one has hit all of it.
You need to pass your arguments.
You need to use the 'Average' function correctly
You also need to change your variables to Single, Long is going to round up or down which will really mess up your results.
Here's a sample of how to fix it:
Sub sem3avg(ByVal w As Single, ByVal x As Single, ByVal y As Single)
If y = 0 Then
Call sem2avg
ElseIf y > 0 Then
Worksheets("Sheet1").Range("H1").Value = Application.WorksheetFunction.Average(w, x, y)
End If
End Sub
Sub sem4avg()
Dim w As Single
Dim x As Single
Dim y As Single
Dim z As Single
w = Worksheets("Sheet1").Range("B11")
x = Worksheets("Sheet1").Range("B23")
y = Worksheets("Sheet1").Range("E11")
z = Worksheets("Sheet1").Range("E23")
If z = 0 Then
Call sem3avg(w, x, y)
ElseIf z > 0 Then
Worksheets("Sheet1").Range("H1").Value = Application.WorksheetFunction.Average(w, x, y, z)
End If
End Sub
The function Application.WorksheetFunction.Average does not work like that. Instead, you need to pass it a bunch of number like so :
Application.WorksheetFunction.Average(w,x,y,z)
https://msdn.microsoft.com/en-us/library/office/ff836809.aspx