Run function for multiple data sets and output results to different cells - vba

I have been trying forever to try and figure this out. I have a set of data in a certain sheet in my Excel file. I have written code so that it outputs some of that information to another sheet. I don't know how to get the function to loop through all the different data sets and output them into the "Output" sheet in my excel file on different rows.
This is what I have so far. Can someone please help?
How do I get the function to run through about 6 data sets that include 5 cells in the column until there are 2 blank cells?
How do I output those different results to another sheet? I already have them outputting the first data set and it works fine. I just need to know how to do the other ones.
Thank you!
Sub EstBatch()
'variables
Dim N As String
Dim D As Date
Dim P As Integer
Dim H As Single
Dim NS As Integer
Dim NL As Integer
Dim BP As Currency
Dim OH As Single
Dim OC As Currency
Dim TP As Currency
Dim PPBR As Currency
Dim EHP As Single
Dim batches As Range
'inputs
N = Sheets("Batch Input").Range("A1").Value
D = Sheets("Batch Input").Range("B1").Value
P = Sheets("Batch Input").Range("A2").Value
H = Sheets("Batch Input").Range("A3").Value
PPBR = Sheets("User Form").Range("C22").Value
EHP = Sheets("User Form").Range("C23").Value
Range("A1").Select
'Processes
BP = P * PPBR
OH = H - 5
If P > 120 Or P < 20 Then
MsgBox ("Cannot Accommodate Group")
ElseIf P >= 20 And P <= 25 Then
NS = 1
NL = 0
ElseIf P >= 26 And P <= 50 Then
NS = 2
NL = 0
ElseIf P >= 51 And P <= 60 Then
NS = 0
NL = 1
ElseIf P >= 61 And P <= 85 Then
NS = 1
NL = 1
ElseIf P >= 86 And P <= 120 Then
NS = 0
NL = 2
End If
If OH > 4 Then
OH = 4
OC = BP * OH * EHP
ElseIf 0 < OH <= 4 Then
OC = BP * OH * EHP
ElseIf OH <= 0 Then
OC = 0
End If
TP = BP + OC
'outputs
Sheets("Batch Output").Range("A2").Value = N
Sheets("Batch Output").Range("B2").Value = D
Sheets("Batch Output").Range("C2").Value = P
Sheets("Batch Output").Range("D2").Value = H
Sheets("Batch Output").Range("E2").Value = PPBR
Sheets("Batch Output").Range("F2").Value = EHP
Sheets("Batch Output").Range("G2").Value = NS
Sheets("Batch Output").Range("H2").Value = NL
Sheets("Batch Output").Range("I2").Value = BP
Sheets("Batch Output").Range("J2").Value = OH
Sheets("Batch Output").Range("K2").Value = OC
Sheets("Batch Output").Range("L2").Value = TP
End Sub

Welcome to StackOverflow. Great first question.
I think what you're reaching for is how to use loops in solving a problem like this.
One easy way to do loops is with a counter, as in the examples I've given below. If appropriate, you can also use a range of cells to loop through data, as described in this answer: https://stackoverflow.com/a/19394207/2665195.
Starting with your second question: if you want a separate sheet for each output you can use Sheets.Add and paste into that new sheet. To do this you will want to use a variable naming convention like Sheets("Batch Output" & X).Range. In this way you can Dim X as Integer and loop through the process incrementing the X integer with each loop. Here's some sample code you can adapt for your purpose:
Sub ExampleAddSheets()
Dim intX As Integer
intX = 1
Dim wsBatchOutput As Worksheet
For intX = 1 To 6
Set wsBatchOutput = Worksheets.Add 'adds a worksheet and tags it to a variable
wsBatchOutput.Name = "BatchOutput" & intX 'names the worksheet
wsBatchOutput.Range("A1").Value = "Data here. Example " & intX
Next intX
Set wsBatchOutput = Nothing
End Sub
I don't know what your data source looks like, but hopefully it is set up in a way that you can turn the inputs aquisition into a loop. For example, if the data came into the system in rows (which your example does not seem to do) you could just increment the row number, something like this:
Sub ExampleSetInputs()
'variables
Dim N As String
Dim D As Date
Dim P As Integer
Dim H As Single
Dim PPBR As Currency
Dim EHP As Single
Dim intRow As Integer
intRow = 2
'inputs
For intRow = 2 To 7
N = Sheets("Batch Input").Range("A" & intRow).Value
D = Sheets("Batch Input").Range("B" & intRow).Value
P = Sheets("Batch Input").Range("C" & intRow).Value
H = Sheets("Batch Input").Range("D" & intRow).Value
Next intRow
End Sub
I hope this helps with your challenge.

Related

"Out of memory" error for very large tridimensional array

I am trying to populate and then perform calculations based on a rather large array. This is to populate a binomial tree to calculate option price, so after populating the array I would need to perform repeated calculation so I'd prefer having 3 dimensions in my array for easy reference further down in the code. First dimension is the number of periods that have passed, second dimension is the number of price increases and the third is the number of price decreases.
Dim arr() As Double
Dim periods As Integer
Dim p As Long, i As Long
Dim u As Double, d As Double
Dim iniprice As Double
Let periods = 400
Let iniprice = 100
Let u = 1.1
Let d = 0.9
ReDim arr(0 To periods, 0 To periods, 0 To periods)
Let arr(0, 0, 0) = iniprice
For p = 1 To UBound(arr, 1)
For i = 0 To p
arr(p, i, p - i) = WorksheetFunction.RoundDown(arr(0, 0, 0) * u ^ i * d ^ (p - i), 2)
Next i
Next p
Is this a limitation stemming from the amount of RAM available on my PC (currently having 8Gb) or is this a limitation of VBA itself? Since one period is usually one day, a periods value of 1000 is normal (252 days = 1 trading year).
I also noticed that I have a lot of unused values, because I want to populate only values that have this format arr(p, i, p-i), values such as arr(10,10,10) will be 0. I'd greatly appreciate a workaround to this.
You can try using a single lookup column to represent the 3D array (not the best way but helps with the memory errors):
Dim periods As Integer
Dim p As Long, i As Long
Dim u As Double, d As Double
Dim iniprice As Double
Dim d1 As Long, d2 As Long, d3 As Long, someRow As Long
Dim fndRange As Range
Let periods = 400
Let iniprice = 100
Let u = 1.1
Let d = 0.9
' Col A will be your lookup in format "X-X-X", Col B will hold values
With Sheets("some sheet")
.Range("B1") = iniprice
For d1 = 0 To periods
For d2 = 0 To periods
For d3 = 0 To periods
.Range("A" & someRow).Value = d1 & "-" & d2 & "-" & d3
someRow = someRow + 1
Next
Next
Next
End With
For p = 1 To periods
For i = 0 To p
Set fndRange = Sheets("some sheet").Columns(1).Find(p & "-" & i & "-" & (p-1))
fndRange.Offset(0,1).Value = WorksheetFunction.RoundDown(iniprice * u ^ i * d ^ (p - i), 2)
Next i
Next p

Excel VBA: "Next Without For" Error

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.

VBA Error: "The object invoked has disconnected from its clients"

I am attempting to write a macro that matches up x/y coordinates to ellipses that they fit into. I get the automation error at the "Else" line in my code. I have reviewed a lot of other posts but I can't figure out what is wrong with my code. Any assistance is much appreciated. Thank you!
Private Sub CommandButton1_Click()
Dim XR As Integer
Dim XC As Integer
Dim YR As Integer
Dim YC As Integer
Dim areaR As Integer
Dim areaC As Integer
Dim hR As Integer
Dim hC As Integer
Dim kR As Integer
Dim kC As Integer
Dim aR As Integer
Dim aC As Integer
Dim bR As Integer
Dim bC As Integer
Dim angleR As Integer
Dim angleC As Integer
Dim matchR As Integer
Dim matchC As Integer
XR = 2
XC = 1
YR = 2
YC = 2
Do Until ThisWorkbook.Sheets("Sheet1").Cells(XR, XC).Value = ""
ThisWorkbook.Sheets("Sheet1").Activate
areaR = 2
areaC = 6
hR = 2
hC = 7
kR = 2
kC = 8
aR = 2
aC = 9
bR = 2
bC = 10
angleR = 2
angleC = 11
matchR = XR
matchC = 12
Do Until ThisWorkbook.Sheets("Sheet1").Cells(hR, hC).Value = ""
If (((((ThisWorkbook.Sheets("Sheet1").Cells(XR, XC).Value) _
- (ThisWorkbook.Sheets("Sheet1").Cells(hR, hC).Value)) * _
Cos((ThisWorkbook.Sheets("Sheet1").Cells(angleR, angleC).Value)) _
+ ((ThisWorkbook.Sheets("Sheet1").Cells(YR, YC).Value) - _
(ThisWorkbook.Sheets("Sheet1").Cells(kR, kC).Value)) * Sin _
((ThisWorkbook.Sheets("Sheet1").Cells(angleR, angleC).Value))) ^ 2) _
/ ((Cells(aR, aC).Value) ^ 2)) + (((((Cells(XR, XC).Value) - _
(Cells(hR, hC).Value)) * Sin((ThisWorkbook.Sheets("Sheet1").Cells _
(angleR, angleC).Value)) - ((ThisWorkbook.Sheets("Sheet1").Cells(YR, YC).Value) _
- (ThisWorkbook.Sheets("Sheet1").Cells(kR, kC).Value)) _
* Cos((Cells(angleR, angleC).Value))) ^ 2) / ((Cells(bR, bC).Value) ^ 2)) _
<= 1 Then
ThisWorkbook.Sheets("Sheet1").Cells(matchR, matchC).Value = _
ThisWorkbook.Sheets("Sheet1").Cells(areaR, areaC)
Else
areaR = areaR + 1
hR = hR + 1
kR = kR + 1
aR = aR + 1
bR = bR + 1
angleR = angleR + 1
End If
Loop
XR = XR + 1
YR = YR + 1
Loop
End Sub
That's a lot of code, and doing direct math with cell reference values is very hard to read...probably even for you.
It may not be much of an answer, but if you create variables (yes, more variables), inside your loops, then your code will be easier to read for everyone and very possibly your error will emerge.
So instead of using ThisWorkbook.Sheets("Sheet1").Cells(XR, XC).Value in your calculation, first do this: X = ThisWorkbook.Sheets("Sheet1").Cells(XR, XC).Value
But don't stop there. Include intermediate variable that will self-describe your code and the calculation process.
This will hopefully allow you to see the code for what it really does.
isMatch = cosX <= 1
If isMatch Then
And, by the way, my suspission is that your error is coming from the fact that you are not qualifying all of your Cells methods with a sheets reference.

Inserting to table in VB.NET, LINQ to SQL

This is the beginnings of a timetabling algorithm. The problem is with inserting a member into a group, but I have included the whole subroutine here for context. The table "membergroup" has 2 headings, MemberID and GroupID. No error code is thrown, but the table does not receive the new record.
I have gone through it line by line, and the values for iMember_Choice.MemberID and groupID_to_insert are correct.
Dim numberofrooms As Byte = rm.Count
Dim possiblerooms(numberofrooms + 1), possibleroomcounter As Int32
For TimeTableNumber = 1 To Val(NumberOfTimetablesToCreate.Text)
Dim memchoic = (dc.ExecuteQuery(Of memberChoice)("SELECT * FROM MemberChoices ORDER BY NEWID()")).ToList 'Orders list randomly
'sort into array for each rank, so highest ranks are allocated first
Dim Member_choices_Table_ordered_by_rank = From q In memchoic Order By q.Rank
For Each Member_Choice In Member_choices_Table_ordered_by_rank
ProgressBar.Value = ProgressBar.Value + 1
Dim iMember_Choice As memberChoice = Member_Choice
'Dim memactpossibleinstance(maxmemchoicernk, n) As memactvpossibleinstance
For Each room In rm
Dim rmid As Int32 = room.RoomID ' finds rooms activities can be in
If Not (From rom In roomact Where rom.ActivityID = iMember_Choice.ActivityID And rom.RoomID = rmid).FirstOrDefault Is Nothing Then 'finds suitable rooms
possiblerooms(possibleroomcounter) = rmid
possibleroomcounter = possibleroomcounter + 1
End If
Next
'find possible times
Dim roomid_to_insert, current_maximum_rank As Integer
Dim period_to_insert As String = "MonAM"
Dim staffact_that_can_do_this_activity = _
(From q In staffact Where q.ActivityID = iMember_Choice.ActivityID)
For roomcount = 0 To possibleroomcounter - 1 'for each room in roomcount, find rank for room
Dim rmid As Int32 = possiblerooms(roomcount)
For Each time In periods
Dim itime As String = time.Period
Dim Rank As Int16 = member_Error_check_period_count(iMember_Choice.MemberID, itime)
If Not (From rav In rmav Where rav.RoomID = rmid And rav.Period = itime) Is Nothing Then 'room is free
Rank = Rank + 12
Else ' room has an activity
Dim GroupID_now = (From q In instnce Where q.Period = itime And q.RoomID = rmid Select q.GroupID).SingleOrDefault
If GroupID_now <> 0 Then
Dim groupActID_now = (From q In grp Where q.GroupID = GroupID_now Select q.ActivityID).SingleOrDefault
'Dim activity_now = (From q In actv Where q.ActivityID = groupActID_now).SingleOrDefault
If groupActID_now = iMember_Choice.ActivityID Then 'Good, this activity is already on in this room
Rank = Rank + 50
If (From q In memgrp Where q.GroupID = GroupID_now).Count > 4 Then
Rank = Rank - 50
End If
End If
End If
End If
If Rank > current_maximum_rank Then
current_maximum_rank = Rank
roomid_to_insert = rmid
period_to_insert = itime
End If
Rank = 0
Next
possibleroomcounter = 0
Next 'for each room possible
Dim groupID_to_insert As Integer
If (From q In instnce Where q.Period = period_to_insert And q.RoomID = roomid_to_insert).FirstOrDefault Is Nothing Then
groupID_to_insert = insert_ins_group(period_to_insert, roomid_to_insert, iMember_Choice.ActivityID)
Else
groupID_to_insert = (From q In instnce Where q.Period = period_to_insert And q.RoomID = roomid_to_insert Select q.GroupID).SingleOrDefault
End If
'PROBLEM PROBPBLY HERE/////////////////////////////////////
memgrp.InsertOnSubmit(New membergroup With {.MemberID = iMember_Choice.MemberID, .GroupID = groupID_to_insert}) 'PROBLEM PROBABLY HERE
dc.SubmitChanges()
current_maximum_rank = 0
Next 'for each memberchoice
dc.SubmitChanges()
Next 'timetabl no
dc.SubmitChanges()
memgrp is initiated as
Dim memgrp As Table(Of membergroup) = dc.GetTable(Of membergroup)()

Next without For Error while formatting a worksheet

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).