Avatar of Matt Guidry
Matt Guidry
Flag for United States of America

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)

  1. if the TGas(i) Value Is greater than 35 at the index position, obtain calculated sub values of  c1,c2,c3.
  2. the ending condition value for the do until loop is set
  3. add lAccum until Do loop condition is met
  4. increase the inner index
  5.  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

Open in new window

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



Open in new window

VBAMicrosoft Excel* arrays

Avatar of undefined
Last Comment
ste5an

8/22/2022 - Mon