I've been trying to run the following code without luck. Nothing happens:
dim Dim OutputDataBordyRange As Range
Dim OutputCell As Range
For Each OutputCell In OutputDataBordyRange.Cells
If OutputCell Is Nothing Then
OutputCell.Value = 0
End If
Next OutputCell
Any suggestions?
Edit. I've tried below suggestions without luck. therefore, as requested, find below full code:
Sub Output_SBTB()
Dim InputDataRange As Range
Dim InputCountryRange As Range
Dim InputSiteRange As Range
Dim InputServiceLineRange As Range
Dim InputCalcHourlySalaryRateRange As Range
Dim InputRegionRange As Range
Dim OutputDataBodyRange As Range
Dim OutputHearderRowRange As Range
Dim OutputArrayColumns As Long
Dim OutputArrayRows As Long
Dim OutputArray() As Variant
Dim OutputArrayCounter As Long
Dim InputRowCounter As Long
Dim MatchRegion As Long
Dim InputCurrentSiteRowsCount As Long
Dim i As Long
Dim OutputCell As Range
Set InputDataRange = ThisWorkbook.Worksheets(Sheet3.Name).PivotTables("PivotTableData").DataBodyRange
Set InputCountryRange = ThisWorkbook.Worksheets(Sheet3.Name).PivotTables("PivotTableData").PivotFields("Country").DataRange
Set InputSiteRange = ThisWorkbook.Worksheets(Sheet3.Name).PivotTables("PivotTableData").PivotFields("Site").DataRange
Set InputServiceLineRange = ThisWorkbook.Worksheets(Sheet3.Name).PivotTables("PivotTableData").PivotFields("Serviceline").DataRange
Set InputCalcHourlySalaryRateRange = ThisWorkbook.Worksheets(Sheet3.Name).PivotTables("PivotTableData").PivotFields("CalcHourlySalaryRate").DataRange
Set InputRegionRange = ThisWorkbook.Worksheets(Sheet4.Name).PivotTables("PivotTableRegion").PivotFields("Country").DataRange
Set OutputDataBodyRange = ThisWorkbook.Worksheets(Sheet2.Name).ListObjects("TableOutput").DataBodyRange
Set OutputHearderRowRange = ThisWorkbook.Worksheets(Sheet2.Name).ListObjects("TableOutput").HeaderRowRange
OutputArrayColumns = InputDataRange.Rows.Count
OutputArrayRows = OutputHearderRowRange.Columns.Count
ReDim Preserve OutputArray(OutputArrayRows, 1)
OutputArrayCounter = 0
If Not OutputDataBodyRange Is Nothing Then
OutputDataBodyRange.Delete
End If
For InputRowCounter = 1 To InputDataRange.Rows.Count
If InputSiteRange(InputRowCounter) <> InputSiteRange(InputRowCounter - 1) Then
OutputArrayCounter = OutputArrayCounter + 1
ReDim Preserve OutputArray(OutputArrayRows, OutputArrayCounter)
MatchRegion = Application.WorksheetFunction.Match(InputCountryRange(InputRowCounter), InputRegionRange, 0)
OutputArray(1, OutputArrayCounter) = InputRegionRange(MatchRegion).Offset(0, -1)
OutputArray(2, OutputArrayCounter) = InputCountryRange(InputRowCounter)
OutputArray(3, OutputArrayCounter) = InputSiteRange(InputRowCounter)
InputCurrentSiteRowsCount = Application.WorksheetFunction.CountIf(InputSiteRange, OutputArray(3, OutputArrayCounter)) - 1
For i = 0 To InputCurrentSiteRowsCount
' *** Landscaping & Irrigation System ***
If InputServiceLineRange(InputRowCounter + i) = "3.2.3-3.2.4 Landscaping & Irrigation System" Or InputServiceLineRange(InputRowCounter + i) = "Landscaping & Irrigation System - SBTB" Then
If InputCalcHourlySalaryRateRange(InputRowCounter + i) = "(blank)" Then
OutputArray(4, OutputArrayCounter) = OutputArray(4, OutputArrayCounter) + InputDataRange(InputRowCounter + i, 1)
OutputArray(5, OutputArrayCounter) = OutputArray(5, OutputArrayCounter) + InputDataRange(InputRowCounter + i, 2)
OutputArray(6, OutputArrayCounter) = OutputArray(6, OutputArrayCounter) + InputDataRange(InputRowCounter + i, 3)
Else
OutputArray(4, OutputArrayCounter) = OutputArray(4, OutputArrayCounter) + InputDataRange(InputRowCounter + i, 1) + InputCalcHourlySalaryRateRange(InputRowCounter + i) * InputDataRange(InputRowCounter + i, 4)
OutputArray(5, OutputArrayCounter) = OutputArray(4, OutputArrayCounter) + InputDataRange(InputRowCounter + i, 2) + InputCalcHourlySalaryRateRange(InputRowCounter + i) * InputDataRange(InputRowCounter + i, 5)
OutputArray(6, OutputArrayCounter) = OutputArray(4, OutputArrayCounter) + InputDataRange(InputRowCounter + i, 3) + InputCalcHourlySalaryRateRange(InputRowCounter + i) * InputDataRange(InputRowCounter + i, 6)
End If
End If
' *** Interior Plant and Tree Maintenance ***
If InputServiceLineRange(InputRowCounter + i) = "3.2.11 Interior Plant and Tree Maintenance" Or InputServiceLineRange(InputRowCounter + i) = "Interior Plant and Tree Maintenance - SBTB" Then
If InputCalcHourlySalaryRateRange(InputRowCounter + i) = "(blank)" Then
OutputArray(7, OutputArrayCounter) = OutputArray(7, OutputArrayCounter) + InputDataRange(InputRowCounter + i, 1)
OutputArray(8, OutputArrayCounter) = OutputArray(8, OutputArrayCounter) + InputDataRange(InputRowCounter + i, 2)
OutputArray(9, OutputArrayCounter) = OutputArray(9, OutputArrayCounter) + InputDataRange(InputRowCounter + i, 3)
Else
OutputArray(7, OutputArrayCounter) = OutputArray(7, OutputArrayCounter) + InputDataRange(InputRowCounter + i, 1) + InputCalcHourlySalaryRateRange(InputRowCounter + i) * InputDataRange(InputRowCounter + i, 4)
OutputArray(8, OutputArrayCounter) = OutputArray(8, OutputArrayCounter) + InputDataRange(InputRowCounter + i, 2) + InputCalcHourlySalaryRateRange(InputRowCounter + i) * InputDataRange(InputRowCounter + i, 5)
OutputArray(9, OutputArrayCounter) = OutputArray(9, OutputArrayCounter) + InputDataRange(InputRowCounter + i, 3) + InputCalcHourlySalaryRateRange(InputRowCounter + i) * InputDataRange(InputRowCounter + i, 6)
End If
End If
' *** Interior Pest Control ***
If InputServiceLineRange(InputRowCounter + i) = "3.3.10 Interior Pest Control" Or InputServiceLineRange(InputRowCounter + i) = "Pest Control - SBTB" Then
If InputCalcHourlySalaryRateRange(InputRowCounter + i) = "(blank)" Then
OutputArray(10, OutputArrayCounter) = OutputArray(10, OutputArrayCounter) + InputDataRange(InputRowCounter + i, 1)
OutputArray(11, OutputArrayCounter) = OutputArray(11, OutputArrayCounter) + InputDataRange(InputRowCounter + i, 2)
OutputArray(12, OutputArrayCounter) = OutputArray(12, OutputArrayCounter) + InputDataRange(InputRowCounter + i, 3)
Else
OutputArray(10, OutputArrayCounter) = OutputArray(10, OutputArrayCounter) + InputDataRange(InputRowCounter + i, 1) + InputCalcHourlySalaryRateRange(InputRowCounter + i) * InputDataRange(InputRowCounter + i, 4)
OutputArray(11, OutputArrayCounter) = OutputArray(11, OutputArrayCounter) + InputDataRange(InputRowCounter + i, 2) + InputCalcHourlySalaryRateRange(InputRowCounter + i) * InputDataRange(InputRowCounter + i, 5)
OutputArray(12, OutputArrayCounter) = OutputArray(12, OutputArrayCounter) + InputDataRange(InputRowCounter + i, 3) + InputCalcHourlySalaryRateRange(InputRowCounter + i) * InputDataRange(InputRowCounter + i, 6)
End If
End If
Next i
End If
Next InputRowCounter
ThisWorkbook.Worksheets(Sheet2.Name).Range("A3:L" & OutputArrayCounter) = Application.WorksheetFunction.Transpose(OutputArray)
For Each OutputCell In OutputDataBodyRange.Cells
If OutputCell.Value = vbNullString Then
OutputCell.Value = 0
End If
Next OutputCell
End Sub
If anything needs to be specified, please let me know.
If the cells are actually empty, you could skip the loop and just use:
On Error Resume Next
OutputDataBordyRange.SpecialCells(xlcelltypeblanks).Value2 = 0
On Error Goto 0
The Nothing keyword is not used to see if a cell is empty, it is used to see if a variable holds the default value for it's declared data type, or assign the default value to it (see this for more information).
Try the following:
For Each OutputCell In OutputDataBordyRange.Cells
If OutputCell.Value = vbNullString Then
OutputCell.Value = 0
End If
Next OutputCell
Related
This question already has answers here:
Declaration of multiple arrays on a single line in VBA
(2 answers)
Closed 6 months ago.
I was trying to create a code to find intersection points between a Rotated rectangle and some horizontal lines
at this line there's an error "ByRef argument type mismatch" when I try to run the code
aa(i) = IntersectComplex(XLine1(i), YLine1(i), XLine2(i), YLine2(i), Side1, True)
Especially at "XLine1(i)" which is highlighted after clicking ok on the error message box
Full Code
Dim Xc(1 To 4) As Double
Dim Yc(1 To 4) As Double
Dim Theta_D, Theta_R As Double
Dim Xc_R(1 To 4) As Double
Dim Yc_R(1 To 4) As Double
Dim Side1, Side2, Side3, Side4 As Range
Dim nfibers As Integer
Dim x1(1 To 4), x2(1 To 4), y1(1 To 4), y2(1 To 4) As Double
Dim tf() As Double
Dim Yf(), df() As Double
Dim XLine1(), XLine2(), YLine1(), YLine2() As Double
Dim aa(), bb(), cc(), dd() As Double
Dim Xint1(), Xint2(), Xint3(), Xint4() As Variant
Dim Yint1(), Yint2(), Yint3(), Yint4() As Double
Dim Px1(), Px2() As Double
Dim XCG(), YCG() As Double
nfibers = 30
ReDim tf(1 To nfibers) As Double
ReDim Yf(1 To nfibers + 1), df(1 To nfibers + 1) As Double
ReDim XLine1(1 To nfibers + 1), XLine2(1 To nfibers + 1), YLine1(1 To nfibers + 1), YLine2(1 To nfibers + 1) As Double
ReDim aa(1 To nfibers + 1), bb(1 To nfibers + 1), cc(1 To nfibers + 1), dd(1 To nfibers + 1) As Double
ReDim Xint1(1 To nfibers + 1), Xint2(1 To nfibers + 1), Xint3(1 To nfibers + 1), Xint4(1 To nfibers + 1) As Variant
ReDim Yint1(1 To nfibers + 1), Yint2(1 To nfibers + 1), Yint3(1 To nfibers + 1), Yint4(1 To nfibers + 1) As Double
ReDim Px1(1 To nfibers + 1), Px2(1 To nfibers + 1) As Double
ReDim XCG(1 To nfibers), YCG(1 To nfibers) As Double
b = ThisWorkbook.Worksheets("Sheet1").Range("C2").Value
t = ThisWorkbook.Worksheets("Sheet1").Range("C3").Value
Theta_D = ThisWorkbook.Worksheets("Sheet1").Range("C4").Value
Theta_R = Application.WorksheetFunction.Radians(Theta_D)
Cos_T = Math.Cos(Theta_R)
Sin_T = Math.Sin(Theta_R)
Tan_T = Math.Tan(Theta_R)
Xc(1) = b / 2
Xc(2) = -b / 2
Xc(3) = -b / 2
Xc(4) = b / 2
Xc(5) = b / 2
Yc(1) = t / 2
Yc(2) = t / 2
Yc(3) = -t / 2
Yc(4) = -t / 2
Yc(5) = t / 2
ThisWorkbook.Worksheets("Sheet1").Range("G3").Value = Xc(1)
ThisWorkbook.Worksheets("Sheet1").Range("G4").Value = Xc(2)
ThisWorkbook.Worksheets("Sheet1").Range("I3").Value = Xc(2)
ThisWorkbook.Worksheets("Sheet1").Range("I4").Value = Xc(3)
ThisWorkbook.Worksheets("Sheet1").Range("K3").Value = Xc(3)
ThisWorkbook.Worksheets("Sheet1").Range("K4").Value = Xc(4)
ThisWorkbook.Worksheets("Sheet1").Range("M3").Value = Xc(4)
ThisWorkbook.Worksheets("Sheet1").Range("M4").Value = Xc(1)
ThisWorkbook.Worksheets("Sheet1").Range("H3").Value = Yc(1)
ThisWorkbook.Worksheets("Sheet1").Range("H4").Value = Yc(2)
ThisWorkbook.Worksheets("Sheet1").Range("J3").Value = Yc(2)
ThisWorkbook.Worksheets("Sheet1").Range("J4").Value = Yc(3)
ThisWorkbook.Worksheets("Sheet1").Range("L3").Value = Yc(3)
ThisWorkbook.Worksheets("Sheet1").Range("L4").Value = Yc(4)
ThisWorkbook.Worksheets("Sheet1").Range("N3").Value = Yc(4)
ThisWorkbook.Worksheets("Sheet1").Range("N4").Value = Yc(1)
Set Side1 = Range("G3:H4")
Set Side2 = Range("I3:J4")
Set Side3 = Range("K3:L4")
Set Side4 = Range("M3:N4")
For i = 1 To 4 Step 1
Xc_R(i) = (Xc(i) * Cos_T) + (Yc(i) * Sin_T)
Yc_R(i) = (-Xc(i) * Sin_T) + (Yc(i) * Cos_T)
Next i
Y1max = Application.WorksheetFunction.Large(Yc_R, 1)
Y2max = Application.WorksheetFunction.Large(Yc_R, 2)
Y3max = Application.WorksheetFunction.Large(Yc_R, 3)
Y4max = Application.WorksheetFunction.Large(Yc_R, 4)
hzone1 = Y1max - Y2max
hzone2 = Y2max - Y3max
hzone3 = Y3max - Y4max
d1max = Y1max - Y1max
d2max = Y1max - Y2max
d3max = Y1max - Y3max
d4max = Y1max - Y4max
'each zone has equal fibers but not equal fiber thicknesses
If Theta_D = 0 Or Theta_D = 90 Or Theta_D = 180 Or Theta_D = 270 Or Theta_D = 360 Then
nfibers_Zone1 = 0
tf_zone1 = 0
nfibers_Zone2 = nfibers
tf_zone2 = hzone2 / nfibers_Zone2
nfibers_Zone3 = 0
tf_zone3 = 0
Else
nfibers_Zone1 = nfibers / 3
tf_zone1 = hzone1 / nfibers_Zone1
nfibers_Zone2 = nfibers / 3
tf_zone2 = hzone2 / nfibers_Zone2
nfibers_Zone3 = nfibers / 3
tf_zone3 = hzone3 / nfibers_Zone3
End If
'Line Starts and ends
For i = 1 To 4
x1(i) = Xc_R(i)
x2(i) = Xc_R(i + 1)
y1(i) = Yc_R(i)
y2(i) = Yc_R(i + 1)
Next i
'Horizontal Lines for fibers
'Different zones
'Zone1
For i = 0 To nfibers
If i >= 0 And i < nfibers / 3 Then
tff = tf_zone1
ElseIf i >= (nfibers / 3) And i < (2 / 3) * nfibers Then
tff = tf_zone2
Else
tff = tf_zone3
End If
Yf(i) = Y1max - (tff * i)
df(i) = Y1max - Yf(i)
YLine1(i) = Yf(i)
YLine2(i) = Yf(i)
XLine1(i) = -100000
XLine2(i) = 100000
On Error Resume Next
aa(i) = IntersectComplex(XLine1(i), YLine1(i), XLine2(i), YLine2(i), Side1, True)
bb(i) = IntersectComplex(XLine1(i), YLine1(i), XLine2(i), YLine2(i), Side2, True)
cc(i) = IntersectComplex(XLine1(i), YLine1(i), XLine2(i), YLine2(i), Side3, True)
dd(i) = IntersectComplex(XLine1(i), YLine1(i), XLine2(i), YLine2(i), Side4, True)
Xint1(i) = Application.WorksheetFunction.IfError(aa(i), "")
Xint2(i) = Application.WorksheetFunction.IfError(bb(i), "")
Xint3(i) = Application.WorksheetFunction.IfError(cc(i), "")
Xint4(i) = Application.WorksheetFunction.IfError(dd(i), "")
Yint1(i) = Yf(i)
Yint2(i) = Yf(i)
Yint3(i) = Yf(i)
Yint4(i) = Yf(i)
If Xint1(i) <> "" Then
Px1(i) = Xint1(i)
ElseIf Xint2(i) <> "" Then
Px1(i) = Xint2(i)
ElseIf Xint3(i) <> "" Then
Px1(i) = Xint3(i)
End If
If Xint2(i) <> "" Then
Px2(i) = Xint2(i)
ElseIf Xint3(i) <> "" Then
Px2(i) = Xint3(i)
ElseIf Xint4(i) <> "" Then
Px2(i) = Xint4(i)
End If
Next i
For i = 1 To nfibers
XCG(i) = Application.WorksheetFunction.Average(Px1(i), Px2(i))
YCG(i) = Application.WorksheetFunction.Average(Yf(i), Yf(i))
Debug.Print XCG(i)
Debug.Print YCG(i)
Next i
The error occurs because you declared several variables separated by commas Dim XLine1(), XLine2(), YLine1(), YLine2() As Double, without specifying the type of each of them, but only the last one. Thus, all variables except the last one are of type Variant by default. See Dim statement: "Use a separate As type clause for each variable you declare.".
Passing a variable of type Variant instead of Double to the Public Function IntersectComplex(x1 As Double, y1 As Double, x2 As Double, y2 As Double, LineCoordinates As Range, Axis As Boolean) As Variant by reference causes a type error.
See the example below:
Sub testWrong()
Dim arr(), arr2() As Double 'arr() was declared as Variant by default, arr2() was explicitly declared as Double
ReDim arr(1 To 2), arr2(1 To 2) As Double
arr(1) = 100
arr2(1) = 200
foo arr(1), arr2(1) ' passed arr(1) ByRef as Variant. Raise error "ByRef argument type mismatch": expected Double, passed Variant
End Sub
Sub foo(x As Double, x2 As Double)
Debug.Print x * x2
End Sub
Sub testRight()
Dim arr() As Double, arr2() As Double 'you need to explicitly specify the type after each variable
ReDim arr(1 To 2), arr2(1 To 2) ' no need to specify type here
arr(1) = 100
arr2(1) = 200
foo arr(1), arr2(1) 'no error
End Sub
I am working on a module that is running calculations of demand for a panelboard. The function created exports a value for demand. I am trying to pull values that were defined in the calculation. For example the value that is assigned to totalrecep how would I be able to call that in another sub?
I want to be able to call some of the values that are defined in the demand function.
Function Demand(myRange As Range)
Application.Volatile ' this causes the sheet to automatically update
Dim LoadtypeA, LoadtypeB, LoadtypeC, Load1 As Excel.Range 'defines the ranges
Dim newdemand As Double
totalrecep = 0
totaldemand = 0
motordemanda = 0
recepdemanda = 0
Contdemanda = 0
otherdemanda = 0
motordemandb = 0
recepdemandb = 0
Contdemandb = 0
otherdemandb = 0
motordemandc = 0
recepdemandc = 0
Contdemandc = 0
otherdemandc = 0
motorMAX = 0
cont25 = 0
motor25 = 0
recepdeduct = 0
Poles = 84
'===========================================================================================
'This is for the first section of the panel
'===========================================================================================
'Set Load1 = Worksheets(ActiveSheet.Name).Range("F7:F48") 'gets the range
Set Load1 = myRange
'This is for the left side of the panel
For x = 1 To (Poles / 2)
LoadtypeA = Load1(x)
LoadtypeB = Load1(x + 1)
LoadtypeC = Load1(x + 2)
'MsgBox Loadtype
'----------------------------------------------------------------
Select Case LoadtypeA
Case "R"
'MsgBox "R"
recepdemanda = recepdemanda + Load1(x, 2)
Case "M"
'MsgBox "m"
motordemanda = motordemanda + Load1(x, 2)
If Load1(x, 2) > motorMAXa Then
motorMAXa = Load1(x, 2)
End If
Case "C"
'MsgBox "C"
Contdemanda = Contdemanda + Load1(x, 2)
Case "N"
'MsgBox "N"
otherdemanda = otherdemanda + Load1(x, 2)
End Select
'----------------------------------------------------------------
Select Case LoadtypeB
Case "R"
'MsgBox "R"
recepdemandb = recepdemandb + Load1(x + 1, 2)
Case "M"
'MsgBox "M"
motordemandb = motordemandb + Load1(x + 1, 2)
If Load1(x + 1, 2) > motorMAXb Then
motorMAXb = Load1(x + 1, 2)
End If
Case "C"
'MsgBox "C"
Contdemandb = Contdemandb + Load1(x + 1, 2)
Case "N"
'MsgBox "N"
otherdemandb = otherdemandb + Load1(x + 1, 2)
End Select
'----------------------------------------------------------------
Select Case LoadtypeC
Case "R"
'MsgBox "R"
recepdemandc = recepdemandc + Load1(x + 2, 2)
Case "M"
'MsgBox "M"
motordemandc = motordemandc + Load1(x + 2, 2)
If Load1(x + 2, 2) > motorMAXc Then
motorMAXc = Load1(x + 2, 2)
End If
Case "C"
'MsgBox "C"
Contdemandc = Contdemandc + Load1(x + 2, 2)
Case "N"
'MsgBox "N"
otherdemandc = otherdemandc + Load1(x + 2, 2)
End Select
'----------------------------------------------------------------
x = x + 2
Next x
'----------------------------------------------------------------
' End of Left side of panel
'----------------------------------------------------------------
' Begin right side of panel
For x = 1 To (Poles / 2)
LoadtypeA = Load1(x, 11)
LoadtypeB = Load1(x + 1, 11)
LoadtypeC = Load1(x + 2, 11)
'MsgBox Loadtype
'----------------------------------------------------------------
Select Case LoadtypeA
Case "R"
'MsgBox "R"
recepdemanda = recepdemanda + Load1(x, 10)
Case "M"
'MsgBox "M"
motordemanda = motordemanda + Load1(x, 10)
If Load1(x, 10) > motorMAXa Then
motorMAXa = Load1(x, 10)
End If
Case "C"
'MsgBox "C"
Contdemanda = Contdemanda + Load1(x, 10)
Case "N"
'MsgBox "N"
otherdemanda = otherdemanda + Load1(x, 10)
End Select
'----------------------------------------------------------------
Select Case LoadtypeB
Case "R"
'MsgBox "R"
recepdemandb = recepdemandb + Load1(x + 1, 10)
Case "M"
'MsgBox "M"
motordemandb = motordemandb + Load1(x + 1, 10)
If Load1(x + 1, 10) > motorMAXb Then
motorMAXb = Load1(x + 1, 10)
End If
Case "C"
'MsgBox "C"
Contdemandb = Contdemandb + Load1(x + 1, 10)
Case "N"
'MsgBox "N"
otherdemandb = otherdemandb + Load1(x + 1, 10)
End Select
'----------------------------------------------------------------
Select Case LoadtypeC
Case "R"
'MsgBox "R"
recepdemandc = recepdemandc + Load1(x + 2, 10)
Case "M"
'MsgBox "M"
motordemandc = motordemandc + Load1(x + 2, 10)
If Load1(x + 2, 10) > motorMAXc Then
motorMAXc = Load1(x + 2, 10)
End If
Case "C"
'MsgBox "C"
Contdemandc = Contdemandc + Load1(x + 2, 10)
Case "N"
'MsgBox "N"
otherdemandc = otherdemandc + Load1(x + 2, 10)
End Select
'----------------------------------------------------------------
x = x + 2
Next x
'----------------------------------------------------------------
' End of Right side of panel
' Begin Demand Calcs
' Total Panel Calcs
'----------------------------------------------------------------
cont25 = (Contdemanda + Contdemandb + Contdemandc) * 0.25
motor25 = (motorMAXa + motorMAXb + motorMAXc) * 0.25
contdemand = Contdemanda + Contdemandb + Contdemandc
motordemand = motordemanda + motordemandb + motordemandc
totalrecep = recepdemanda + recepdemandb + recepdemandc
otherdemand = otherdemanda + otherdemandb + otherdemandc
If totalrecep > 10 Then
recepdemand = ((totalrecep - 10) / 2 + 10)
End If
If totalrecep < 10 Then
recepdemand = totalrecep
End If
newdemand = recepdemand + contdemand + motordemand + otherdemand + cont25 + motor25
'newdemand = Load1(1)
Demand = newdemand
'----------------------------------------------------------------
End Function
Create a public variable outside function and inside function
assigned your a public variable to local function variable.
then you can call a public variable from any place.
Option Explicit
Public x As String
Function myFun()
Dim name As String
name = "Hearno"
x = name
End Function
Sub Test()
Debug.Print x ' Hearno
End Sub
I have a raw data sheet and am trying to process nps scores from the emergency department (ANE) versus all others.
I am counting the values and transferring the number of promoters, detractors and passives onto a sheet which I can then calculate the net promoter score for that month.
I have four institutes which are being surveyed and it's run as such.
I receive
Compile error next without for.
Which End If is causing the error, or am I missing more End Ifs?
Dim UNITAOutpatientANEPromoter As Integer
Dim UNITBOutpatientANEPromoter As Integer
Dim UNITCOutpatientANEPromoter As Integer
Dim UNITDOutpatientANEPromoter As Integer
Dim ALLOutpatientANEPromoter As Integer
Dim UNITAOutpatientANEDetractor As Integer
Dim UNITBOutpatientANEDetractor As Integer
Dim UNITCOutpatientANEDetractor As Integer
Dim UNITDOutpatientANEDetractor As Integer
Dim ALLOutpatientANEDetractor As Integer
Dim UNITAOutpatientANEPassive As Integer
Dim UNITBOutpatientANEPassive As Integer
Dim UNITCOutpatientANEPassive As Integer
Dim UNITDOutpatientANEPassive As Integer
Dim ALLOutpatientANEPassive As Integer
Dim UNITAOutpatientOtherPromoter As Integer
Dim UNITBOutpatientOtherPromoter As Integer
Dim UNITCOutpatientOtherPromoter As Integer
Dim UNITDOutpatientOtherPromoter As Integer
Dim ALLOutpatientOtherPromoter As Integer
Dim UNITAOutpatientOtherDetractor As Integer
Dim UNITBOutpatientOtherDetractor As Integer
Dim UNITCOutpatientOtherDetractor As Integer
Dim UNITDOutpatientOtherDetractor As Integer
Dim ALLOutpatientOtherDetractor As Integer
Dim UNITAOutpatientOtherPassive As Integer
Dim UNITBOutpatientOtherPassive As Integer
Dim UNITCOutpatientOtherPassive As Integer
Dim UNITDOutpatientOtherPassive As Integer
Dim ALLOutpatientOtherPassive As Integer
UNITAOutpatientANEPromoter = 0
UNITBOutpatientANEPromoter = 0
UNITCOutpatientANEPromoter = 0
UNITDOutpatientANEPromoter = 0
ALLOutpatientANEPromoter = 0
UNITAOutpatientANEDetractor = 0
UNITBOutpatientANEDetractor = 0
UNITCOutpatientANEDetractor = 0
UNITDOutpatientANEDetractor = 0
ALLOutpatientANEDetractor = 0
UNITAOutpatientANEPassive = 0
UNITBOutpatientANEPassive = 0
UNITCOutpatientANEPassive = 0
UNITDOutpatientANEPassive = 0
ALLOutpatientANEPassive = 0
UNITAOutpatientOtherPromoter = 0
UNITBOutpatientOtherPromoter = 0
UNITCOutpatientOtherPromoter = 0
UNITDOutpatientOtherPromoter = 0
ALLOutpatientOtherPromoter = 0
UNITAOutpatientOtherDetractor = 0
UNITBOutpatientOtherDetractor = 0
UNITCOutpatientOtherDetractor = 0
UNITDOutpatientOtherDetractor = 0
ALLOutpatientOtherDetractor = 0
UNITAOutpatientOtherPassive = 0
UNITBOutpatientOtherPassive = 0
UNITCOutpatientOtherPassive = 0
UNITDOutpatientOtherPassive = 0
ALLOutpatientOtherPassive = 0
Dim mycount As Integer
mycount = Worksheets("1. Raw").Range("A1", Worksheets("1. Raw").Range("A1").End(xlDown)).Rows.Count - 1
'MsgBox (mycount)
If (mycount = 0 Or mycount = 1) Then
MsgBox ("Need raw data first")
Else 'mycount > 1
Dim i As Integer
'MsgBox (mycount)
For i = 1 To mycount
If (Worksheets("1. Raw").Cells(i + 1, 1)) = "OUTPATIENT" Then
'UNITA
If (Worksheets("1. Raw").Cells(i + 1, 2)) = "UNITA" Then
If (Worksheets("1. Raw").Cells(i + 1, 6)) = "A&E-A" Then
If (Worksheets("1. Raw").Cells(i + 1, 22)) = "Promoter" Then
UNITAOutpatientANEPromoter = UNITAOutpatientANEPromoter + 1
ElseIf (Worksheets("1. Raw").Cells(i + 1, 22)) = "Detractor" Then
UNITAOutpatientANEDetractor = UNITAOutpatientANEDetractor + 1
ElseIf (Worksheets("1. Raw").Cells(i + 1, 22)) = "Passive" Then
UNITAOutpatientANEPassive = UNITAOutpatientANEPassive + 1
End If
Else
If (Worksheets("1. Raw").Cells(i + 1, 22)) = "Promoter" Then
UNITAOutpatientOtherPromoter = UNITAOutpatientOtherPromoter + 1
ElseIf (Worksheets("1. Raw").Cells(i + 1, 22)) = "Detractor" Then
UNITAOutpatientOtherDetractor = UNITAOutpatientOtherDetractor + 1
ElseIf (Worksheets("1. Raw").Cells(i + 1, 22)) = "Passive" Then
UNITAOutpatientOtherPassive = UNITAOutpatientOtherPassive + 1
End If
End If
'UNITB
ElseIf (Worksheets("1. Raw").Cells(i + 1, 1)) = "UNITB" Then
If (Worksheets("1. Raw").Cells(i + 1, 6)) = "A&E-B" Then
If (Worksheets("1. Raw").Cells(i + 1, 22)) = "Promoter" Then
UNITBOutpatientANEPromoter = UNITBOutpatientANEPromoter + 1
ElseIf (Worksheets("1. Raw").Cells(i + 1, 22)) = "Detractor" Then
UNITBOutpatientANEDetractor = UNITBOutpatientANEDetractor + 1
ElseIf (Worksheets("1. Raw").Cells(i + 1, 22)) = "Passive" Then
UNITBOutpatientANEPassive = UNITBOutpatientANEPassive + 1
End If
Else
If (Worksheets("1. Raw").Cells(i + 1, 22)) = "Promoter" Then
UNITBOutpatientOtherPromoter = UNITBOutpatientOtherPromoter + 1
ElseIf (Worksheets("1. Raw").Cells(i + 1, 22)) = "Detractor" Then
UNITBOutpatientOtherDetractor = UNITBOutpatientOtherDetractor + 1
ElseIf (Worksheets("1. Raw").Cells(i + 1, 22)) = "Passive" Then
UNITBOutpatientOtherPassive = UNITBOutpatientOtherPassive + 1
End If
End If
'UNITC
ElseIf (Worksheets("1. Raw").Cells(i + 1, 1)) = "UNITC" Then
If (Worksheets("1. Raw").Cells(i + 1, 6)) = "A&E-C" Then
If (Worksheets("1. Raw").Cells(i + 1, 22)) = "Promoter" Then
UNITCOutpatientANEPromoter = UNITCOutpatientANEPromoter + 1
ElseIf (Worksheets("1. Raw").Cells(i + 1, 22)) = "Detractor" Then
UNITCOutpatientANEDetractor = UNITCOutpatientANEDetractor + 1
ElseIf (Worksheets("1. Raw").Cells(i + 1, 22)) = "Passive" Then
UNITCOutpatientANEPassive = UNITCOutpatientANEPassive + 1
End If
Else
If (Worksheets("1. Raw").Cells(i + 1, 22)) = "Promoter" Then
UNITCOutpatientOtherPromoter = UNITCOutpatientOtherPromoter + 1
ElseIf (Worksheets("1. Raw").Cells(i + 1, 22)) = "Detractor" Then
UNITCOutpatientOtherDetractor = UNITCOutpatientOtherDetractor + 1
ElseIf (Worksheets("1. Raw").Cells(i + 1, 22)) = "Passive" Then
UNITCOutpatientOtherPassive = UNITCOutpatientOtherPassive + 1
End If
End If
'UNITD
Else
If (Worksheets("1. Raw").Cells(i + 1, 1)) = "UNITD" Then
If (Worksheets("1. Raw").Cells(i + 1, 6)) = "A&E-D" Then
If (Worksheets("1. Raw").Cells(i + 1, 22)) = "Promoter" Then
UNITDOutpatientANEPromoter = UNITDOutpatientANEPromoter + 1
ElseIf (Worksheets("1. Raw").Cells(i + 1, 22)) = "Detractor" Then
UNITDOutpatientANEDetractor = UNITDOutpatientANEDetractor + 1
ElseIf (Worksheets("1. Raw").Cells(i + 1, 22)) = "Passive" Then
UNITDOutpatientANEPassive = UNITDOutpatientANEPassive + 1
End If
Else
If (Worksheets("1. Raw").Cells(i + 1, 22)) = "Promoter" Then
UNITDOutpatientOtherPromoter = UNITDOutpatientOtherPromoter + 1
ElseIf (Worksheets("1. Raw").Cells(i + 1, 22)) = "Detractor" Then
UNITDOutpatientOtherDetractor = UNITDOutpatientOtherDetractor + 1
ElseIf (Worksheets("1. Raw").Cells(i + 1, 22)) = "Passive" Then
UNITDOutpatientOtherPassive = UNITDOutpatientOtherPassive + 1
End If
End If
End If
Next i
End If
All of those variables will give you a headache sooner or later: it would be easier to maintain a more-flexible approach such as below, using a Dictionary to collect the counts, keyed using a combination of the values you're interested in.
Sub Tester()
Dim wsRaw As Worksheet
Dim i As Integer, valUnit, valType, AandE As String, dict As Object, k, lastRow As Long
Set dict = CreateObject("scripting.dictionary")
Set wsRaw = Worksheets("1. Raw")
lastRow = wsRaw.Cells(Rows.Count, "A").End(xlUp).Row
'MsgBox (mycount)
If lastRow < 2 Then
MsgBox ("Need raw data first")
Exit Sub
End If
For i = 2 To lastRow
If wsRaw.Cells(i, "A") = "OUTPATIENT" Then
valUnit = Trim(wsRaw.Cells(i, "B").Value)
valType = Trim(wsRaw.Cells(i, 22).Value)
AandE = IIf(Trim(wsRaw.Cells(i, 6).Value) = "A&E-A", "A&E", "NonA&E") 'is this A&E ?
Select Case valUnit
Case "UNITA", "UNITB", "UNITC", "UNITD" 'counting this unit?
Select Case valType
Case "Promoter", "Detractor", "Passive" 'counting this type?
k = valUnit & "-" & valType & "-" & AandE 'create key for dictionary
dict(k) = dict(k) + 1 'increment count for key
End Select
End Select
End If 'outpatient
Next i
'output all the collected keys and counts
For Each k In dict
Debug.Print k, dict(k)
Next k
End Sub
I'm new to VBA
I have the following method in Java to find the high-low elements in an array, but I do not know how to do the same on VBA Excel. The problem is with translating the IF to compare the previous, the current and the next element in the array {if (arr[i] > arr[i + 1] && arr[i] > arr[i - 1])}, which in the case of Excel is how to find the previous, the current and the next element in a column of cells while the ForEach is running.
public static ArrayList<Integer> sequence(int[] arr) {
System.out.println(" HIGHEST HIGH " + arr.length);
ArrayList<Integer> relHigh = new ArrayList<Integer>();
ArrayList<Integer> relLow = new ArrayList<Integer>();
ArrayList<Integer> hestHigh = new ArrayList<Integer>();
ArrayList<Integer> lestLow = new ArrayList<Integer>();
int highest = -9999999;
int lowest = 9999999;
for (int i = 1; i < arr.length - 2; i++) {
// System.out.println(" I: " + i + " : " + arr[i]);
if (arr[i] > arr[i + 1] && arr[i] > arr[i - 1]) {
relHigh.add(arr[i]);
System.out.println("RelHigh I: " + i + " : " + arr[i]);
if (arr[i] > highest) {
hestHigh.add(arr[i]);
highest = arr[i];
System.out.println("HH I: " + i + " : " + arr[i]);
}
}
if (arr[i] < arr[i + 1] && arr[i] < arr[i - 1]) {
relLow.add(arr[i]);
System.out.println("RelLow I: " + i + " : " + arr[i]);
if (arr[i] < lowest) {
lestLow.add(arr[i]);
lowest = arr[i];
System.out.println("LL I: " + i + " : " + arr[i]);
}
}
}
return relHigh;
}
Sub MaxMin()
Dim myCount As Integer
Dim i As Integer
Dim relHigh As Double
Dim relLow As Double
Dim hestHigh As Double
Dim lestLow As Double
Dim highest As Double
Dim lowest As Double
Dim Cellx As Range
Dim MyRange As Range
Set MyRange = ThisWorkbook.Sheets("Hoja1").Range("A:A").CurrentRegion
Dim previous As Double
Dim current As Double
Dim next As Double
Dim rCell As Range
Dim rRng As Range
Set rRng = Sheets("Hoja1").Range("A1:A15")
For Each rCell In rRng.Cells
Debug.Print rCell.Address, rCell.Value
**// Here is where I get lost**
if (arr[i] > arr[i + 1] && arr[i] > arr[i - 1]) {
Next rCell
End Sub
You can assign a column of data to an array using Transpose. You can't add to an array (without re-dimensioning) but you can add to a Collection.
Function sequence(ByRef rng As Range) As Variant
' assign range to array
Dim arr As Variant
arr = WorksheetFunction.Transpose(rng.Value2)
Dim relHigh As New Collection, relLow As New Collection
Dim highestHigh As New Collection, lowestLow As New Collection
Dim highest As Long, lowest As Long, i As Long
Dim highestRow As Long, lowestRow As Long
highest = -9999999
lowest = 9999999
' clear formatting
rng.Cells.ClearFormats
rng.Columns(2).Clear
For i = 2 To UBound(arr) - 1
If (arr(i) > arr(i + 1)) And (arr(i) > arr(i - 1)) Then
relHigh.Add arr(i)
'System.out.println("RelHigh I: " + i + " : " + arr[i]);
Debug.Print "RelHigh I:" & i & " : " & arr(i)
rng.Cells(i, 1).Font.Color = RGB(0, 200, 0)
rng.Cells(i, 1).Font.Bold = True
rng.Cells(i, 2) = "relHigh"
If (arr(i) > highest) Then
highestHigh.Add arr(i)
highest = arr(i)
highestRow = i
'System.out.println("HH I: " + i + " : " + arr[i]);
Debug.Print "HH I:" & i & " : " & arr(i)
End If
End If
If (arr(i) < arr(i + 1)) And (arr(i) < arr(i - 1)) Then
relLow.Add arr(i)
rng.Cells(i, 1).Font.Color = vbRed
'System.out.println("RelLow I: " + i + " : " + arr[i]);
Debug.Print "RelLow I:" & i & " : " & arr(i)
rng.Cells(i, 1).Font.Color = RGB(200, 0, 0)
rng.Cells(i, 1).Font.Bold = True
rng.Cells(i, 2) = "relLow"
If (arr(i) < lowest) Then
lowestLow.Add arr(i)
lowest = arr(i)
lowestRow = 1
'System.out.println("HH I: " + i + " : " + arr[i]);
Debug.Print "LL I:" & i & " : " & arr(i)
End If
End If
' store latest
If (arr(i) = highest) Then highestRow = i
If (arr(i) = lowest) Then lowestRow = i
Next
'highest / lowest
rng.Cells(highestRow, 2) = "hestHigh"
rng.Cells(lowestRow, 2) = "lestLow"
' return relHigh collection as an array
Dim arrOut() As Integer
ReDim arrOut(1 To relHigh.Count, 1 To 1)
For i = 1 To relHigh.Count
Debug.Print i, relHigh(i)
arrOut(i, 1) = relHigh(i)
Next
sequence = arrOut
End Function
I'm working with userform to add data in a Table "t_database". For each checkbox = true, add a ROW.
When i add some data, appear "Run-time error '9' Subscript out of range..
To create this code, i used a post founded here and i completed with my requeriments.
Option Explicit
Private Sub cmdAddproject_Click()
Dim chkCnt As Integer
Dim ctl As MSForms.Control, i As Integer, lr As Long
Dim cb As MSForms.CheckBox
With Me
chkCnt = .Tool1.Value + .Tool2.Value + .Tool3.Value + .Tool4.Value + .Tool5.Value + .Tool6.Value + .Tool7.Value + .Tool8.Value + .Tool9.Value + .Tool10.Value + .Tool11.Value + .Tool12.Value + .Tool13.Value + .Tool14.Value + .Tool15.Value + .Tool16.Value + .Tool7.Value + .Tool18.Value + .Tool19.Value + .Tool20.Value + .Tool21.Value + .Tool22.Value + .Tool23.Value + .Tool24.Value + .Tool25.Value + .Tool26.Value + .Tool27.Value + .Tool28.Value + .Tool29.Value + .Tool30.Value
chkCnt = Abs(chkCnt)
If chkCnt <> 0 Then
ReDim mval(1 To chkCnt, 1 To 17)
i = 1
For Each ctl In .Controls
If TypeOf ctl Is MSForms.CheckBox Then
Set cb = ctl
If cb Then
mval(i, 1) = .txtProyecto.Value
mval(i, 2) = .txtAno.Value
mval(i, 3) = .txtEmpresa.Value
mval(i, 4) = .SectorEmpresa.Value
mval(i, 5) = .TipoEmpresa.Value
mval(i, 6) = .txtDireccion.Value
mval(i, 7) = .txtCiudad.Value
mval(i, 8) = .txtCodigoPostal.Value
mval(i, 9) = .txtPais.Value
mval(i, 10) = .txtDescripcion.Value
mval(i, 11) = .txtIndicador1.Value
mval(i, 12) = .metrica1.Value
mval(i, 13) = .txtIndicador2.Value
mval(i, 14) = .metrica2.Value
mval(i, 15) = cb.Caption
mval(i, 16) = .txtAhorrosPrevistos.Value
mval(i, 17) = .txtAhorrosObtenidos.Value
i = i + 1
End If
End If
Next
End If
End With
With Sheets("Database")
lr = .Range("A" & .Rows.Count).End(xlUp).Row + 1
.Range("A" & lr).Resize(UBound(mval, 1), 17) = mval
End With
End Sub