How come VBA excel keeps running the statement inside a conditional statement even if it is false? - vba

I am trying to create an automatic filling of the payroll spreadsheet I created. However, no matter how much I try it the value of z = 1 all the time even if the logic returns FALSE values (I validated this using MsgBox).
My goal in this code is to check whether there is already a record in another sheet. If there isn't it will automatically add the record with the appropriate details based on the available data.
Below is the full VBA code (Note code is incomplete so it is a bit unpolished still):
Option Explicit
Public p As Long
Sub test()
Dim Total_rows_PR As Long
Dim Total_rows_DTR As Long
Total_rows_PR = Worksheets("Payroll - Regular").Range("B" & Rows.Count).End(xlUp).Row
Total_rows_DTR = Worksheets("DTR").Range("B" & Rows.Count).End(xlUp).Row
Dim q As Long
Dim j As Long
Dim z As Long
For j = 1 To Total_rows_DTR - 1
For q = 1 To Total_rows_PR + p - 2
If Worksheets("DTR").Cells(1 + j, 33) = Worksheets("Payroll - Regular").Cells(2 + q, 1) Then
If Worksheets("DTR").Cells(1 + j, 34) = Worksheets("Payroll - Regular").Cells(2 + q, 2) Then
If Worksheets("DTR").Cells(1 + j, 2) = Worksheets("Payroll - Regular").Cells(2 + q, 3) Then
z = 1
Exit For
End If
End If
End If
Next q
' Below is where the assignment should happen but only returns a blank cell
If z = 0 Then Worksheets("Payroll - Regular").Cells(Total_rows_PR + 1 + p, 1) = Worksheets("DTR").Cells(1 + j, 33)
If z = 0 Then Worksheets("Payroll - Regular").Cells(Total_rows_PR + 1 + p, 2) = Worksheets("DTR").Cells(1 + j, 34)
If z = 0 Then Worksheets("Payroll - Regular").Cells(Total_rows_PR + 1 + p, 3) = Worksheets("DTR").Cells(1 + j, 2)
If z = 0 Then p = p + 1
z = 0
Next j
End Sub
Update: I realized that even if the conditions are not being a met in the first portion of If-Then loops, the value of z is set to 1 for no reason. This is the reason why it won't assign values. However, I do not see why it keeps assigning to 1.
Update#2: #ShaiRado
So the first image is where data is encoded (not shown in image because it is in the leftmost part of the spreadsheet, but basically it inputs the name of the person, date, and the daily time record (DTR) of the person). When the data is encoded, it will automatically indicate what month and year it is based on the helper column AG month and column AH for year. Somewhere in the start of the same worksheet at column B is where the name of the person is. All of these 3 will be used.
This second image is where the summaries are computed. If there is an entry for a specific person at a certain month and year and it is not located in this worksheet, it will automatically fill in that person's name as well as the month and year. Basically that's what the code i'm trying to create does.
The output is a fully automated spreadsheet that only requires data entry in the DTR sheet. All computations already have their corresponding formulas.

First: You have a really strange way of writing your if-statements.
I think what you mean is
For q = 1 To Total_rows_PR + p
If Worksheets("DTR").Cells(1 + j, 33) = Worksheets("Payroll - Regular").Cells(2 + q, 1) _
And Worksheets("DTR").Cells(1 + j, 34) = Worksheets("Payroll - Regular").Cells(2 + q, 2) _
And Worksheets("DTR").Cells(1 + j, 2) = Worksheets("Payroll - Regular").Cells(2 + q, 3) Then
z = 1
Exit For ' Once found, z stays 1 so you don't have to continue the inner loop.
End If
Next q
Second: I am not sure what exactly you want to achieve, but as far as I understand, your problem is that you are looping to far. At the last iteration of the outer loop, your accessing row 1 + j of sheet DTR which is empty at that time, and you are accessing row 2 + q (which is the same as 2 + Total_rows_PR + p) - also empty (and comparing the two emtpy lines sets z to 1).
A variable is never set for no reason. Is is maybe set and you don't understand the reason.
Debug your code step by step, watch where it behaves different as you expect and find the reason why it does what is does.

Related

How can I write a code to define a range insdide a loop that will change its size?

I need to use two Loops and the easy part is to count how many times does a "submodul" repeats in a defined and known range ("B3","B18"), this means the quantity of elements each submodul has. The difficult part comes when trying to count how many times does a "position" repeats for each different "submodul", this is because the amount of elements of each "submodul" is different so I have to adjust a range in a especial Loop to calculate how many times does a specific element (=Position) repeats within a "submodul".
The specific part that I need help with is the following:
positionrepetition = Application.CountIf(Worksheets("Sheet2").range("cells(3 + x + y - 1, 3)", "cells(3 + x + y - 1 + submodulrepetition,3"), position)
If I can manage to write it in a correct format I believe it will work. The problem is that normally I only use the range function when I know that the range is fixed or known, it doesn´t have to be calculated. I normally write for example: Range("A1","F10").Select
As you can see this is a fixed range, so I imagined that instead of using the format of Range("A1", "F10") I could use the range function with the arguments ("Cells(1,1)","Cells(10,6)"). Please correct me if I´m wrong.
Here is the rest of the code for the Loop.
For x = 0 To numberofparts
If Cells(3 + x, 18) = "1" Then
submodul = Cells(3 + x, 2).Value
submodulrepetition = Application.CountIf(Worksheets("Sheet2").range("B3", "B18"), submodul)
For y = 1 To submodulrepetition
position = Cells(3 + x + y - 1, 3).Value
positionrepetition = Application.CountIf(Worksheets("Sheet2").range("cells(3 + x + y - 1, 3)", "cells(3 + x + y - 1 + submodulrepetition,3"), position)
Next
Else
End If
x = x + submodulrepetition - 1
Next
To explain a little more, all data is gathered from Excel Sheets:
-All Information is gathered from a Excel sheet
-The "submodules" are in column B and they are arranged in numerical order. Every submodul repeats in this column as many elements it has.
-The "positions" (elements of the submodules) are in column C and can also repeat in the same column and even in other "Submodul"s.
All help will be appreciated and I thank you in advance.
Alejandro Farina
Change your line:
positionrepetition = Application.CountIf(Worksheets("Sheet2").Range("cells(3 + x + y - 1, 3)", "cells(3 + x + y - 1 + submodulrepetition,3"), Position)
With :
positionrepetition = Application.CountIf(Worksheets("Sheet2").Range(Cells(3 + x + y - 1, 3), Cells(3 + x + y - 1 + submodulrepetition, 3), Position))
If the Range is going to Change by Column/Row use the following code to get the end of column or row:
Dim GetColEnd, GetRowEnd As Integer
GetColEnd = Sheets("Sheet_Name").Cells(1, .Columns.Count).End(xlToLeft).Column
GetRowEnd = Sheets("Sheet_Name").Cells(Rows.Count, 1).End(xlUp).Row
Use the GetColEnd GetRowEnd in your Range function for flexible Column\Row for example as follows:
Sheets("Sheet_Name").Range(Cells(1,1),Cells(GetRowEnd,GetColEnd)

Excel VBA: "Too many different cell formats" - Is there a way to remove or clear these formats in a Macro?

So, I made a fun and simple macro that randomly selects R, G, and B values until it uses every possible combination (skipping repeats), and setting the color values of a 10x10 square with each new color.
The only problem is that I have run into the limit for the number of cell formats. Microsoft says that the limit should be around 64000, but I found it to be exactly 65429 on a blank workbook in Excel 2013.
I've included a clear format code, but it seems to have no effect:
Cells(X, Y).ClearFormats
Microsoft lists some resolutions, but 3 out of the 4 of them are essentially "Don't make too many formats", and the 4th format is to use a third party application.
Is there really nothing that can be done in VBA?
A1:J10 will print a new color
K1 will print the percentage to completion
L1 will print the number of colors used
M1 will print the number of times a color combination is repeated
Dim CA(255, 255, 255) As Integer
Dim CC As Long
Dim RC As Long
Dim R As Integer
Dim G As Integer
Dim B As Integer
Dim X As Integer
Dim Y As Integer
CC = 0
RC = 0
X = 1
Y = 1
Do While ColorCount < 16777216
R = ((Rnd * 256) - 0.5)
G = ((Rnd * 256) - 0.5)
B = ((Rnd * 256) - 0.5)
If CA(R, G, B) <> 1 Then
CA(R, G, B) = 1
'Step down to the next row
'If at the 10th row, jump back to the first and move to the next column
If X < 10 Then
X = X + 1
Else
X = 1
If Y < 10 Then
Y = Y + 1
Else
Y = 1
End If
End If
Cells(X, Y).ClearFormats 'doesn't do what I hope :(
Cells(X, Y).Interior.Color = RGB(R, G, B)
CC = CC + 1
Cells(1, 11).Value = (CC / 16777216) * 100
Cells(1, 12).Value = CC
Else
RC = RC + 1
Cells(1, 13).Value = RC
End If
Loop
There are several ways to resolve this issue, but the cleanest and easiest method is to remove all extra styles (I have seen workbooks with 9000+ styles )
With the following simple VBA code you can remove all non-builtin styles and in the vast majority of cases this fixes the error.
Sub removeStyles()
Dim li as long
On Error Resume Next
With ActiveWorkbook
For li = .Styles.Count To 1 Step -1
If Not .Styles(li).BuiltIn Then
.Styles(li).Delete
End If
Next
End With
End Sub

INDEX MATCH array formula for 1M rows

I have two sets of data that need to be matched based on IDs and timestamp (+/- 3 units converted from time), and below is the formula that I've been using in Excel to do the matching. Recently I've had to run this formula on up to 1 million rows in Excel, and it takes a REALLY long time, crashes too. I'm wondering if there is a faster way to do this, if not in Excel?
=INDEX(A:A,MATCH(1,--(B:B=E3)*--(ABS(C:C-F3)<=3),0),1)
Data Set 1:
Column A: States
Column B: IDs
Column C: Timestamp
Data Set 2:
Column D: Email Addresses
Column E: IDs
Column F: Timestamp
Column G: =INDEX(A:A,MATCH(1,--(B:B=E3)*--(ABS(C:C-F3)<=3),0),1)
Goal: Append "States" Column to Data Set 2 matched on IDs and Timestamp (+/- 3 time units) match.
Just don't know how to run this formula on very large data sets.
Place the following VBA routines in a standard code module.
Run the MIAB1290() routine.
This emulates the precise outcome of your INDEX/MATCH formula, but it is much more efficient. On my computer, a million records are correctly correlated and the results displayed in Column G in just 10 seconds.
Public Sub MIAB1290()
Dim lastB&, k&, e, f, z, v, w, vErr, r As Range
With [a2]
Set r = .Resize(.Item(.Parent.Rows.Count - .Row + 1, 5).End(xlUp).Row - .Row + 1, .Item(, .Parent.Columns.Count - .Column + 1).End(xlToLeft).Column - .Column + 1)
lastB = .Item(.Parent.Rows.Count - .Row + 1, 2).End(xlUp).Row - .Row + 1
End With
With r
.Worksheet.Sort.SortFields.Clear
.Sort Key1:=.Item(1, 2), Order1:=1, Key2:=.Item(1, 2), Order2:=1, Header:=xlYes
v = .Value2
End With
ReDim w(1 To UBound(v), 1 To 1)
vErr = CVErr(xlErrNA)
For k = 2 To UBound(v)
e = v(k, 5)
f = v(k, 6)
w(k, 1) = vErr
z = BSearch(v, 2, e, 1, lastB)
If z Then
Do While v(z, 2) = e
If Abs(v(z, 3) - f) <= 3 Then
w(k, 1) = v(z, 1)
Exit Do
End If
z = z + 1
If z > UBound(v) Then Exit Do
Loop
End If
Next
r(1, 8).Resize(r.Rows.Count) = w
End Sub
Private Function BSearch(vA, col&, vVal, ByVal first&, ByVal last&)
Dim k&, middle&
While last >= first
middle = (last + first) / 2
Select Case True
Case vVal < vA(middle, col)
last = middle - 1
Case vVal > vA(middle, col)
first = middle + 1
Case Else
k = middle - 1
Do While vA(k, col) = vA(middle, col)
k = k - 1
If k > last Then Exit Do
Loop
BSearch = k + 1
Exit Function
End Select
Wend
BSearch = 0
End Function
Excel isn't really made for large ammount of data, and probably no code will do it faster for you then a builtin excel formula. In this case, I would sugest you to give a try to the PowerPivot addin, and see how it handles the situation.

Sorting Arrays or collections

I have the following code as a sub in Excel 2010:
i = 2
For j = 1 To num_scenarios
Dim probdiff As Double
Dim OCS_Spend As Double
n = 0
For k = 1 To num_yrs
' These are the calculations and potentially not relevant to my question but here for context
For Each cell In rng
x = Rnd()
'Debug.Print Format(x, "0.00000%")
If cell.Value >= x Then
'Populate the result sheet
Sheets("Event Occurs").Cells(i, 1) = mywksht.Cells(cell.Row, 1)
Sheets("Event Occurs").Cells(i, 2) = mywksht.Cells(cell.Row, 2)
Sheets("Event Occurs").Cells(i, 3) = mywksht.Cells(cell.Row, 3)
Sheets("Event Occurs").Cells(i, 4) = mywksht.Cells(cell.Row, 4)
Sheets("Event Occurs").Cells(i, 5) = mywksht.Cells(cell.Row, 5)
Sheets("Event Occurs").Cells(i, 6) = mywksht.Cells(cell.Row, 6)
Sheets("Event Occurs").Cells(i, 10) = "Event Occurs"
Sheets("Event Occurs").Cells(i, 11) = mywksht.Cells(cell.Row, 11)
Sheets("Event Occurs").Cells(i, 9) = x
Sheets("Event Occurs").Cells(i, 7) = k
Sheets("Event Occurs").Cells(i, 8) = j
Sheets("Event Occurs").Cells(i, 14) = (cell.Value - x) ^ (2)
event_max = Sheets("Event Occurs").Cells(i, 11)
probdiff = probdiff + (cell.Value - x) ^ (2)
If Round(cell / x, 0) >= event_max Then
Sheets("Event Occurs").Cells(i, 12) = event_max
Else
Sheets("Event Occurs").Cells(i, 12) = Round(cell / x, 0)
End If
Duration = Sheets("Event Occurs").Cells(i, 4)
Num_Event = Sheets("Event Occurs").Cells(i, 12)
Spend = Sheets("Event Occurs").Cells(i, 5)
Sheets("Event Occurs").Cells(i, 13) = Num_Event * Spend / Duration
OCS_Spend = OCS_Spend + Num_Event * Spend / Duration
n = n + 1
i = i + 1
End If
Next cell
' End calculations
Next k
Debug.Print j, probdiff / n
probdiff = 0
OCS_Spend = 0
Next j
The output to the immediate window looks like this:
J: MSE:
1 0.194236476623154
2 0.157939130921924
3 0.19825548826238
4 0.384990330451172
5 0.267128221022187
The first column is j (the outer for loop) and represents a scenario. The second column is the mean square error of the data generated by each iteration of the outer j loop. So 1 is the first time the loop runs,2 is the second etc.. The smaller the number in column MSE, the more likely the scenario is to occur.
I want people to be able to limit the number of scenarios (j's) they see to only the most likely in the event they want to run 100 scenarios. So I need a way of sorting the table above to something like this
j: MSE
2 0.157939130921924
1 0.194236476623154
3 0.19825548826238
5 0.267128221022187
4 0.384990330451172
And if someone wanted to see only the top three results, it would be this:
j: MSE
2 0.157939130921924
1 0.194236476623154
3 0.19825548826238
So basically the three most likely out of 5 possible scenarios. I have tried collections and arrays but not dicitonaries (I am still learning how to use these and not sure if they exists in Excel VBA).
Chip Pearson provides a number of very useful functions which can sort arrays, collections, and dictionaries, which are available here:
http://www.cpearson.com/Excel/SortingArrays.aspx
There is too much code there to reproduce here. What I typically do when the need arises is to create a separate module in my VBProject which contains these array helper functions. I have used these extensively in PowerPoint and they worked in that environment with minimal modifications. For Excel, they should work out-of-the-box.
Once you have put the data in an array (I don't see any arrays in your code, so let's assume you have something like Dim MyArray As Variant), and sorted it using those functions, you can do something like this to cut the array down to include only the first x results:
'where "x" is a long/integer represents some user-input or _
limit to the number of results:
ReDim Preserve MyArray(x - 1)
I would use arrays rather than collections or dictionaries.
Why not Collections? Collections are useful and would arguably do the job, here. However, whereas we can "resize" the array in a single ReDim Preserve statement, you cannot do that with a Collection object; you would instead have to use iteration. While this is not overly complicated, it does seem a bit clunkier. (You could of course do some tests on performance, but unless you are dealing with very large sets of data, I would not expect a noticeable gain either way).
Sub testCollection()
Dim coll As New Collection
Dim i As Integer
For i = 1 To 10
coll.Add i
Next
Dim x As Integer 'The maximum number of results you want to return:
x = 4
Do Until coll.Count = x
coll.Remove (coll.Count)
Loop
End Sub
Why not dictionaries? While a dictionary's .Keys returns a one-dimensional array of values, in order to avoid iteration (like in the collection object) you would still need to transfer these to an array:
MyArray = dict.Keys()
ReDim Preserve MyArray(x-1)
Further, the dictionary object holds unique key values, so these are not good to use if you anticipate that there may be duplicate values that you need to store.
One option is to use a System.Collections.ArrayList since this object directly supports a Sort method. The Object is "borrowed" from VB.NET.
EDIT#1
Here is a sample:
Sub SortDemo()
s = Array("Larry", "Moe", "Curley", "Manny", "Zack", "Jack")
L = LBound(s)
U = UBound(s)
With CreateObject("System.Collections.ArrayList")
For k = L To U
.Add s(k)
Next k
.Sort
s = .toarray
End With
msg = ""
For k = L To U
msg = msg & s(k) & vbCrLf
Next k
MsgBox msg
End Sub
and here are the references in place:
For more information see:
Ozgrid Material

textbox values won't assign to a variable in vba

I was running tests on my software today and found that some of the values it was producing weren't correct.
I decided to step through the code and noticed that the variables I had assigned to textbox values on my userform when hovered over said empty, even though when hovering over the textbox assigned to it, the value inputted by the user showed.
For Example,
n = BiTimeSteps_TextBox.Value
when hovered over
n = empty
even though
BiTimeSteps_TextBox.Value = 2
when hovered over.
So say I have a formula shortly after that says
d = n*2 ,
n when hovered over says empty and d is made 0 when it shouldn't be.
Someone told me if I switch it around to
BiTimeSteps_TextBox.Value = n
it should be recognised but it is still not.
What could possibly be causing this?
See full code below: (it aims to price options using the binomial tree pricing method)
S = BiCurrentStockPrice_TextBox.Value
X = BiStrikePrice_TextBox.Value
r = BiRisk_Free_Rate_TextBox.Value
T = BiexpTime_TextBox.Value
Sigma = BiVolatility_TextBox.Value
n = BiTimeSteps_TextBox.Value
Dim i, j, k As Integer
Dim p, V, u, d, dt As Double
dt = T / n ' This finds the value of dt
u = Exp(Sigma * Sqr(dt)) 'formula for the up factor
d = 1 - u 'formula for the down factor
'V value of option
'array having the values
Dim bin() As Double 'is a binomial arrays, it stores the value of each node, there is a loop
'work out the risk free probability
p = (1 + r - d) / (u - d)
'probability of going up
ReDim bin(n + 1) As Double
'it redims the array, and n+1 is used because it starts from zero
'------------------------------------------------------------------------------------------------------------------------------
''European Call
If BiCall_CheckBox = True Then
For i = 0 To n 'payoffs = value of option at final time
bin(i + 1) = Application.WorksheetFunction.Max(0, (u ^ (n - i)) * (d ^ i) * S - X)
'It takes the max payoff or 0
Cells(i + 20, n + 2) = bin(i + 1) 'to view payoffs on the isolated column on the right
Next i
End If
'european put
If BiPut_CheckBox = True Then
For i = 0 To n 'payoffs = value of option at final time
bin(i + 1) = Application.WorksheetFunction.Max(0, X - (S * (u * (n - i)) * (d * i)))
' European Put- It takes the max payoff or 0
Cells(i + 20, n + 2) = bin(i + 1) 'to view payoffs on the isolated column on the right
Next i
End If
For k = 1 To n 'backward column loop
For j = 1 To (n - k + 1) 'loop down the column loop
bin(j) = (p * bin(j) + (1 - p) * bin(j + 1)) / (1 + r)
Cells(j + 19, n - k + 2) = bin(j)
'' print the values along the column, view of tree
Next j
Next k
Worksheets("Binomial").Cells(17, 2) = bin(1) ' print of the value V
BiOptionPrice_TextBox = bin(1)