asked on
Improving efficiency of working VBA modules, tips on better practices that i am unable to see
The for each loop contains a do loop that gets executed when the condition is met.
It seems to me the do until loop is where it is slowing down at writing to each of the 3arrays combined - all doubles. The values written get passed to it before the do loop begins. advice?
when it loops back around lAcuum keeps adding till condition is met lAccum = lAccum + arrROPmin(x)
sample_after.csv
The loops in function processGasCalc seem to be what nearly causes excel to crash
It seems to me the do until loop is where it is slowing down at writing to each of the 3arrays combined - all doubles. The values written get passed to it before the do loop begins. advice?
when it loops back around lAcuum keeps adding till condition is met lAccum = lAccum + arrROPmin(x)
- if the TGas(i) Value Is greater than 35 at the index position, obtain calculated sub values of c1,c2,c3.
- the ending condition value for the do until loop is set
- add lAccum until Do loop condition is met
- increase the inner index
- Can't seem to get O/X not surpass the Ubounds of the array limits its writing to without subtracting 1 - an extra undesired iteration occurs
sample_after.csv
The loops in function processGasCalc seem to be what nearly causes excel to crash
Option Explicit
Global _
DataWB As Workbook, DataWS As Worksheet, _
rngC1 As Range, rngC2 As Range, rngC3 As Range, _
startDepth As Double, EndDepth As Double, _
i As Integer, _
dLBd As Double, dUBd As Double
'<------------------Set mininum limit for TGas to be processed------->
Const TGasLmt As Double = 25
'<------------------interval for data loop------------->
'its derived from how much footage within a 2.5min cycle gets same chromat values
Const WVI As Double = 10.2
Sub Call_me()
readRangetoArray (8615.5)
End Sub
Function readRangetoArray(ByVal userInput As Double)
Call Config_Functions.declarePublicVars
Dim strIn As String
strIn = "XXXXXX" 'path to csv file of data to be processed then written back to
Workbooks.OpenText Filename:=strIn, DataType:=xlDelimited, comma:=True
Set DataWB = Workbooks(strIn): Set DataWS = DataWB.Sheets(1): DataWB.Save
Dim lROPCol As Long: lROPCol = 2
Dim lTGasCol As Long: lTGasCol = 3
Dim lC1Col As Long: lC1Col = lTGasCol + 1
Dim lC2Col As Long: lC2Col = lTGasCol + 2
Dim lC3Col As Long: lC3Col = lTGasCol + 3
Dim lStartRow As Long
With DataWS
Dim lROPCol As Long: lROPCol = 2
Dim lTGasCol As Long: lTGasCol = 3
Dim lC1Col As Long: lC1Col = lTGasCol + 1
Dim lC2Col As Long: lC2Col = lTGasCol + 2
Dim lC3Col As Long: lC3Col = lTGasCol + 3
Dim lStartRow As Long
With DataWS
lStartRow = .Columns("A").Find(userInput, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=True, _
SearchFormat:=False).Row
startDepth = userInput: LastUsedRow = .cells(.Rows.Count, lTGasCol).End(xlUp).Row: EndDepth = .cells(LastUsedRow, 1)
Set rngC1 = .Range(.cells(lStartRow, lC1Col), .cells(LastUsedRow, lC1Col)) 'identify range to write generated c1
Set rngC2 = .Range(.cells(lStartRow, lC2Col), .cells(LastUsedRow, lC2Col)) 'identify range to write generated c2
Set rngC3 = .Range(.cells(lStartRow, lC3Col), .cells(LastUsedRow, lC3Col)) 'identify range to write generated c3
Dim rngROP As Range: Set rngROP = .Range(.cells(lStartRow, lROPCol), .cells(LastUsedRow, lROPCol)) 'Set ROP Range to read from
Dim rngTGas As Range: Set rngTGas = .Range(.cells(lStartRow, lTGasCol), .cells(LastUsedRow, lTGasCol)) 'Set Total Gas Range to read from
End With
Dim arrROP() As Double, arrTGas() As Double
arrROP = rngtoArrD(rngROP) ' pass to function that loops range into array
arrTGas = rngtoArrD(rngTGas) ' pass to function that loops range into array
arrROP = arrROPmin(arrROP) ' pass to function that loops range into array
processGasCalc arrROPmin:=arrROP, arrTGas:=arrTGas
End Function
Function rngtoArrD(rng As Range) As Double()
Dim rCells As Range
Dim tempArr() As Double: ReDim tempArr(rng.cells.Count)
i = 0
For Each rCells In rng
tempArr(i) = CDbl(rCells.Value)
i = i + 1
Next
rngtoArrD = tempArr()
End Function
Function arrROPmin(arr() As Double) As Double()
Dim k As Double, lResult As Double
Dim tempArr() As Double
'dLBd assigned to Low Bounds / dUBd assinged to Upper Bounds of arr
dLBd = LBound(arr): dUBd = UBound(arr)
ReDim tempArr(dLBd To dUBd): For i = dLBd To dUBd: k = i
'-----------------------Areas of concern - better way?----------------------
Select Case True
Case arr(i) > 0: lResult = (60 / arr(i))
Case arr(i) = 0
If k > dUBd Then GoTo exitf
If arr(k) = 0 And k >= dLBd And k < dUBd Then
Do Until arr(k) >= 0
k = k + 1
lResult = (60 / arr(k))
Loop
ElseIf arr(k) = 0 And k < dUBd And k >= dLBd Then
Do Until arr(k) > 0
k = k - 1
If arr(k) > 0 Then
lResult = (60 / arr(k))
End If
Loop
End If
End Select
'-----------------------end Areas of concern - better way?----------------------
tempArr(i) = lResult
Next i
exitf:
ReDim arrROPmin(LBound(tempArr) To UBound(tempArr)): arrROPmin = tempArr()
End Function
Function calcChromatD(TGas As Double, C1F As Double, C2F As Double, C3F As Double)
Dim intC1LmT As Integer, intC2LmT As Integer, intC3LmT As Integer
'Declare limits to assign values of 0 if below
intC1LmT = 25: intC2LmT = 10: intC3LmT = 5
C1F = 0.677737226: C2F = 0.115255474: C3F = 0.077170418
C1F = C1F * TGas: C2F = C2F * TGas: C3F = C3F * TGas
Select Case C1F
Case Is <= intC1LmT: C1F = 0: C2F = 0: C3F = 0: GoTo endfunc
End Select
Select Case C2F
Case Is <= intC2LmT: C2F = 0: C3F = 0: GoTo endfunc
End Select
Select Case C3F
Case Is <= intC3LmT: C3F = 0
End Select
endfunc:
End Function
Function processGasCalc(arrROPmin() As Double, arrTGas() As Double)
Call arrLoadScaleFactors
Dim x As Long, o As Long, gGas As Long
x = 0: gGas = 0: o = 0:
'<------------Set arrC1-C3 to length needed------------>
Dim arrC1() As Double: ReDim arrC1(dLBd To dUBd)
Dim arrC2() As Double: ReDim arrC2(dLBd To dUBd)
Dim arrC3() As Double: ReDim arrC3(dLBd To dUBd)
Dim tempC1 As Double, tempC2 As Double, tempC3 As Double
'for each of the items in arrROPmin values loop
Dim firstPASSbool As Boolean, kROP As Double, lAccum As Double
'-----------------------Areas of concern - better way?----------------------
For x = dLBd To dUBd
'when it loops back around lAcuum updates it self to static
lAccum = lAccum + arrROPmin(x)
If lAccum >= WVI And arrTGas(x) > TGasLmt Or firstPASSbool = False Then
'if the totalgas Value at Rop index position is greater than 35
o = x
calcChromatD TGas:=arrTGas(x), C1F:=tempC1, C2F:=tempC2, C3F:=tempC3
kROP = lAccum + WVI
'inner loop 'lAccum adds ROPmin till get to limit of 11.5
Do Until lAccum >= kROP
'arrC1,C2,C3 are assigned values from 1st Do until Loop
arrC1(o) = tempC1: arrC2(o) = tempC2: arrC3(o) = tempC3: Sleep 15
'Close inner Do until loop when ROPmin has reached 11.5 from previous value
lAccum = lAccum + arrROPmin(o)
o = o + 1
If o >= dUBd Then GoTo exitf
Loop
firstPASSbool = 0
'loops 1st Do While
lAccum = 0
x = o - 1
End If
Next x
'-----------------------end Areas of concern - better way?----------------------
exitf:
writeChromatToRange arrC1:=arrC1, arrC2:=arrC2, arrC3:=arrC3
End Function
Function writeChromatToRange(arrC1 As Variant, arrC2 As Variant, arrC3 As Variant)
rngC1 = Application.WorksheetFunction.Transpose(arrC1)
rngC2 = Application.WorksheetFunction.Transpose(arrC2)
rngC3 = Application.WorksheetFunction.Transpose(arrC3)
Sleep 250
MsgBox "Done"
End Function
The data below is stored in a csv file
The column of data to the right of the total gas column is what the output of this entire module would be
The ROP defines that rate in which how many times the values will be written within a variable time of ROP.
Depth ROP Total Gas
8615.5 124.5 30.1 30 28 0 0 0
8616 121.7 29.45 30 28 0 0 0 0
8616.5 120.6 30.1 30 29 0 0 0 0
8617 121.6 30.38 30 29 0 0 0 0
8617.5 116.8 29.66 30 29 0 0 0 0
8618 113.8 29.7 30 30 0 0 0 0
8618.5 115.5 29.7 30 30 0 0 0 0
8619 112.4 29.62 30 31 0 0 0 0
8619.5 106.8 30.05 30 32 0 0 0 0
8620 100.5 29.3 30 36 0 0 0 0
8620.5 101.7 29.28 30 36 0 0 0 0
8621 117.5 30.51 30 36 0 0 0 0
8621.5 135.5 32.29 30 43 0 0 0 0
8622 132.5 32.84 30 43 0 0 0 0
8622.5 109.5 32.49 30 43 0 0 0 0
8623 95.8 32.51 30 43 0 0 0 0
8623.5 67.8 29.94 30 47 0 0 0 0
8624 56.3 32.82 30 47 0 0 0 0
8624.5 56.2 31.82 30 47 0 0 0 0
8625 52 32.21 30 47 0 0 0 0
8625.5 54.1 30.69 30 47 0 0 0 0
8626 64 27.38 30 41 0 0 0 0
8626.5 95.5 31.91 30 41 0 0 0 0
8627 115.8 31.98 30 41 0 0 0 0
8627.5 93.7 32.58 30 41 0 0 0 0
8628 91.7 31.87 30 41 0 0 0 0
8628.5 93.7 32.57 30 41 0 0 0 0
8629 97.7 31.51 30 41 0 0 0 0
8629.5 104.3 32.33 30 35 0 0 0 0
8630 101.4 31.92 30 35 0 0 0 0
8630.5 94.8 32.98 30 34 0 0 0 0
8631 95 31.6 30 34 0 0 0 0
8631.5 100 32.7 30 30 0 0 0 0
8632 101.2 32.45 30 30 0 0 0 0
8632.5 97.3 32.54 30 30 0 0 0 0
8633 98.5 32.66 30 28 0 0 0 0
8633.5 103 31.85 30 28 0 0 0 0
8634 106.6 32.56 30 28 0 0 0 0
8634.5 106.4 31.79 30 28 0 0 0 0
8635 108.2 32.47 30 26 0 0 0 0
8635.5 109.3 32.27 30 26 0 0 0 0
8636 114.4 32.4 30 26 0 0 0 0
8636.5 119.8 31.93 30 26 0 0 0 0
8637 119.4 32.12 30 26 0 0 0 0
8637.5 127 32.81 30 26 0 0 0 0
8638 134.9 31.9 30 26 0 0 0 0
8638.5 141 32.08 30 26 0 0 0 0
8639 142.9 32.6 30 26 0 0 0 0
8639.5 140.5 32.45 30 26 0 0 0 0
8640 140.7 32.58 30 26 0 0 0 0
8640.5 140.6 32.44 30 28 0 0 0 0
8641 143.9 32 30 28 0 0 0 0
8641.5 145.7 32.26 30 28 0 0 0 0
8642 141.6 32.86 30 29 0 0 0 0
8642.5 141.4 32.41 30 29 0 0 0 0
8643 140.8 32.06 30 29 0 0 0 0
8643.5 143.7 32.32 30 30 0 0 0 0
8644 148.3 32.45 30 30 0 0 0 0
8644.5 154.9 34.22 30 33 0 0 0 0
8645 166.3 34.03 30 33 0 0 0 0
8645.5 163 35.72 30 34 0 0 0 0
8646 153.5 35.74 30 34 0 0 0 0
8646.5 140.6 35 30 71 0 0 0 0
8647 133.5 35.27 30 71 0 0 0 0
8647.5 0 18.56 0 22 0 0 0 0
8648 119.7 20.5 0 22 0 0 0 0
8648.5 82.6 30.96 0 22 0 0 0 0
8649 44.3 33.15 0 20 0 0 0 0
8649.5 31 33.9 0 20 0 0 0 0
8650 0 29.5 7 18 0 0 0 0
8650.5 38 30.5 18 18 0 0 0 0
8651 33.5 32.64 15 19 0 0 0 0
8651.5 25.8 30.84 8 19 0 0 0 0
8652 15.9 28.12 18 20 0 0 0 0
8652.5 13 28.83 10 18 0 0 0 0
8653 17.1 29.9 7 17 0 0 0 0
8653.5 26.4 31.37 18 17 0 0 0 0
8654 0 24.39 19 19 0 0 0 0
8654.5 23.8 27.99 13 19 0 0 0 0
8655 25.7 33.24 9 19 0 0 0 0
8655.5 36.3 39.42 16 18 0 0 0 0
8656 38.5 41.83 18 18 0 0 0 0
8656.5 40.4 44.52 9 18 0 0 0 0
8657 43.2 44.74 7 19 0 0 0 0
8657.5 43.7 44.94 7 19 0 0 0 0
8658 41.4 39.34 12 20 0 0 0 0
8658.5 40.9 38.58 10 23 0 0 0 0
8659 41.9 38.36 9 24 0 0 0 0
8659.5 42.6 38.46 11 25 0 0 0 0
8660 42.2 36.95 11 27 0 0 0 0
8660.5 43.4 38.25 10 28 0 0 0 0
8661 48.9 38.91 16 28 0 0 0 0
8661.5 50 39.24 10 29 0 0 0 0
VBAMicrosoft Excel* arrays
Last Comment
ste5an