Long Code needs array

Question

It's been a while since I dealt with VBA and I wrote something rather un-elegant.

Can someone suggest a way to shorten the below code? I imagine arrays could help, but I don't know how to implement it.

The purpose of the code is to build out systems of threaded pipe, which must be combined in fairly precise lengths. The program always uses the largest length of pipe that fits the remaining amount of desired pipe length.

To keep the code as short as possible, I've omitted the portion where I dimension variables and display results.

Thanks in advance for your help.

Sub ThreadedPipeCalc()

Dim desLength As Single, end1 As String, end2 As String
Dim none As Single, CS_Con As Single, CS_Un As Single
Dim CS_90deg As Double, CS_Tee As Single, CS_Flange As Single
Dim CS_Con_ct As Integer, CS_Un_ct As Integer, CS_Flange_ct As Integer
Dim CS_90deg_ct As Integer, CS_Tee_ct As Integer
Dim CS_Con_ct_tot As Integer, CS_Un_ct_tot As Integer
Dim CS_90deg_ct_tot As Integer, CS_Tee_ct_tot As Integer
Dim A_pipe As Single, B_pipe As Single, C_pipe As Single
Dim D_pipe As Single, E_pipe As Single, F_pipe As Single
Dim H_pipe As Single, I_pipe As Single, J_pipe As Single
Dim K_pipe As Single, L_pipe As Single, M_pipe As Single
Dim N_pipe As Single, O_pipe As Single, P_pipe As Single
Dim Q_pipe As Single, R_pipe As Single, S_pipe As Single
Dim T_pipe As Single, U_pipe As Single, V_pipe As Single
Dim W_pipe As Single, X_pipe As Single, Y_pipe As Single
Dim Z_pipe As Single, Threadin As Single, FULLY_pipe As Single
Dim A_ct As Integer, B_ct As Integer, C_ct As Integer
Dim D_ct As Integer, E_ct As Integer, F_ct As Integer
Dim H_ct As Integer, I_ct As Integer, J_ct As Integer
Dim K_ct As Integer, L_ct As Integer, M_ct As Integer
Dim N_ct As Integer, O_ct As Integer, P_ct As Integer
Dim Q_ct As Integer, R_ct As Integer, S_ct As Integer
Dim T_ct As Integer, U_ct As Integer, V_ct As Integer
Dim W_ct As Integer, X_ct As Integer, Y_ct As Integer
Dim Z_ct As Integer, FULLY_ct As Integer
Dim A_ct_tot As Integer, B_ct_tot As Integer, C_ct_tot As Integer
Dim D_ct_tot As Integer, E_ct_tot As Integer, F_ct_tot As Integer
Dim H_ct_tot As Integer, I_ct_tot As Integer, J_ct_tot As Integer
Dim K_ct_tot As Integer, L_ct_tot As Integer, M_ct_tot As Integer
Dim N_ct_tot As Integer, O_ct_tot As Integer, P_ct_tot As Integer
Dim Q_ct_tot As Integer, R_ct_tot As Integer, S_ct_tot As Integer
Dim T_ct_tot As Integer, U_ct_tot As Integer, V_ct_tot As Integer
Dim W_ct_tot As Integer, X_ct_tot As Integer, Y_ct_tot As Integer
Dim Z_ct_tot As Integer, FULLY_ct_tot As Integer
Dim segCount As Integer
Dim CountRedux As Boolean, continue As Integer

continue = 6
none = 0
CS_Con = 2.53
SS_Con = 2.5
CS_Un = 3
SS_Un = 2.85
CS_90deg = 2.25
SS_90deg = 2.28
CS_Tee = 2.25
SS_Tee = 2.26
CS_Flange = 1
SS_Flange = 1
SS_Flang_red = 1.1875
SS_Cap = 1.77
Threadin = 0.563

A_pipe = 126
B_pipe = 72
C_pipe = 60
D_pipe = 48
E_pipe = 36
F_pipe = 24
G_pipe = 22
H_pipe = 20
I_pipe = 18
J_pipe = 16
K_pipe = 14
L_pipe = 12
M_pipe = 11
N_pipe = 10
O_pipe = 9
P_pipe = 8
Q_pipe = 7
R_pipe = 6.5
S_pipe = 6
T_pipe = 5.5
U_pipe = 5
V_pipe = 4.5
W_pipe = 4
X_pipe = 3.5
Y_pipe = 3
Z_pipe = 2.5
FULLY_pipe = 2

While continue = 6

segCount = 0
Range("C3:C32").Value = 0
CS_Con_ct = 0
CS_Un_ct = 0
CS_90deg_ct = 0
CS_Tee_ct = 0
CS_Flange_ct = 0
A_ct = 0
B_ct = 0
C_ct = 0
D_ct = 0
E_ct = 0
F_ct = 0
G_ct = 0
H_ct = 0
I_ct = 0
J_ct = 0
K_ct = 0
L_ct = 0
M_ct = 0
N_ct = 0
O_ct = 0
P_ct = 0
Q_ct = 0
R_ct = 0
S_ct = 0
T_ct = 0
U_ct = 0
V_ct = 0
W_ct = 0
X_ct = 0
Y_ct = 0
Z_ct = 0
FULLY_ct = 0

CS_Con_ct_tot = Range("D3")
CS_Un_ct_tot = Range("D4")
CS_90deg_ct_tot = Range("D5")
CS_Tee_ct_tot = Range("D6")
A_ct_tot = Range("D7")
B_ct_tot = Range("D8")
C_ct_tot = Range("D9")
D_ct_tot = Range("D10")
E_ct_tot = Range("D11")
F_ct_tot = Range("D12")
G_ct_tot = Range("D13")
H_ct_tot = Range("D14")
I_ct_tot = Range("D15")
J_ct_tot = Range("D16")
K_ct_tot = Range("D17")
L_ct_tot = Range("D18")
M_ct_tot = Range("D19")
N_ct_tot = Range("D20")
O_ct_tot = Range("D21")
P_ct_tot = Range("D22")
Q_ct_tot = Range("D23")
R_ct_tot = Range("D24")
S_ct_tot = Range("D25")
T_ct_tot = Range("D26")
U_ct_tot = Range("D27")
V_ct_tot = Range("D28")
W_ct_tot = Range("D29")
X_ct_tot = Range("D30")
Y_ct_tot = Range("D31")
Z_ct_tot = Range("D32")
FULLY_ct_tot = Range("D33")

desLength = Application.InputBox("Enter the desired end to center or center to center length", Type:=1)
end1 = Application.InputBox("Enter End1 Connection (none, Connector, Union, 90deg, or Tee)", Type:=2)
If end1 = Range("A1") Then
    CountRedux = True
Else
    CountRedux = False
End If
end2 = Application.InputBox("Enter End2 Connection (none, Connector, Union, 90deg, or Tee)", Type:=2)

Range("A1") = end2
Range("B2") = desLength

If end1 = "Connector" Then
    CS_Con_ct = CS_Con_ct + 1
    If CountRedux = False Then CS_Con_ct_tot = CS_Con_ct_tot + 1
    desLength = desLength - CS_Con + Threadin
End If
If end1 = "Union" Then
    CS_Un_ct = CS_Un_ct + 1
    If CountRedux = False Then CS_Un_ct_tot = CS_Un_ct_tot + 1
    desLength = desLength - CS_Un + Threadin
End If
If end1 = "90deg" Then
    CS_90deg_ct = CS_90deg_ct + 1
    If CountRedux = False Then CS_90deg_ct_tot = CS_90deg_ct_tot + 1
    desLength = desLength - CS_90deg + Threadin
End If
If end1 = "Tee" Then
    CS_Tee_ct = CS_Tee_ct + 1
    If CountRedux = False Then CS_Tee_ct_tot = CS_Tee_ct_tot + 1
    desLength = desLength - CS_Tee + Threadin
End If
If end2 = "Connector" Then
    CS_Con_ct = CS_Con_ct + 1
    CS_Con_ct_tot = CS_Con_ct_tot + 1
    desLength = desLength - CS_Con + Threadin
End If
If end2 = "Union" Then
    CS_Un_ct = CS_Un_ct + 1
    CS_Un_ct_tot = CS_Un_ct_tot + 1
    desLength = desLength - CS_Un + Threadin
End If
If end2 = "90deg" Then
    CS_90deg_ct = CS_90deg_ct + 1
    CS_90deg_ct_tot = CS_90deg_ct_tot + 1
    desLength = desLength - CS_90deg + Threadin
End If
If end2 = "Tee" Then
    CS_Tee_ct = CS_Tee_ct + 1
    CS_Tee_ct_tot = CS_Tee_ct_tot + 1
    desLength = desLength - CS_Tee + Threadin
End If

'While desLength >= A_pipe
'    A_ct = A_ct + 1
'    segCount = segCount + 1
'    desLength = desLength - A_pipe
'    If segCount > 2 Then
'        desLength = desLength + CS_Con - Threadin - Threadin
'    End If
'Wend
While desLength >= B_pipe
    B_ct = B_ct + 1
    segCount = segCount + 1
    desLength = desLength - B_pipe
    If segCount >= 2 Then
        desLength = desLength - CS_Con + Threadin + Threadin
    End If
Wend
While desLength >= C_pipe
    C_ct = C_ct + 1
    segCount = segCount + 1
    desLength = desLength - C_pipe
    If segCount >= 2 Then
        desLength = desLength - CS_Con + Threadin + Threadin
    End If
Wend
While desLength >= D_pipe
    D_ct = D_ct + 1
    segCount = segCount + 1
    desLength = desLength - D_pipe
    If segCount >= 2 Then
        desLength = desLength - CS_Con + Threadin + Threadin
    End If
Wend
While desLength >= E_pipe
    E_ct = E_ct + 1
    segCount = segCount + 1
    desLength = desLength - E_pipe
    If segCount >= 2 Then
        desLength = desLength - CS_Con + Threadin + Threadin
    End If
Wend
While desLength >= F_pipe
    F_ct = F_ct + 1
    segCount = segCount + 1
    desLength = desLength - F_pipe
    If segCount >= 2 Then
        desLength = desLength - CS_Con + Threadin + Threadin
    End If
Wend
While desLength >= G_pipe
    G_ct = G_ct + 1
    segCount = segCount + 1
    desLength = desLength - G_pipe
    If segCount >= 2 Then
        desLength = desLength - CS_Con + Threadin + Threadin
    End If
Wend
While desLength >= H_pipe
    H_ct = H_ct + 1
    segCount = segCount + 1
    desLength = desLength - H_pipe
    If segCount >= 2 Then
        desLength = desLength - CS_Con + Threadin + Threadin
    End If
Wend
While desLength >= I_pipe
    I_ct = I_ct + 1
    segCount = segCount + 1
    desLength = desLength - I_pipe
    If segCount >= 2 Then
        desLength = desLength - CS_Con + Threadin + Threadin
    End If
Wend
While desLength >= J_pipe
    J_ct = J_ct + 1
    segCount = segCount + 1
    desLength = desLength - J_pipe
    If segCount >= 2 Then
        desLength = desLength - CS_Con + Threadin + Threadin
    End If
Wend
While desLength >= K_pipe
    K_ct = K_ct + 1
    segCount = segCount + 1
    desLength = desLength - K_pipe
    If segCount >= 2 Then
        desLength = desLength - CS_Con + Threadin + Threadin
    End If
Wend
While desLength >= L_pipe
    L_ct = L_ct + 1
    segCount = segCount + 1
    desLength = desLength - L_pipe
    If segCount >= 2 Then
        desLength = desLength - CS_Con + Threadin + Threadin
    End If
Wend
While desLength >= M_pipe
    M_ct = M_ct + 1
    segCount = segCount + 1
    desLength = desLength - M_pipe
    If segCount >= 2 Then
        desLength = desLength - CS_Con + Threadin + Threadin
    End If
Wend
While desLength >= N_pipe
    N_ct = N_ct + 1
    segCount = segCount + 1
    desLength = desLength - N_pipe
    If segCount >= 2 Then
        desLength = desLength - CS_Con + Threadin + Threadin
    End If
Wend
While desLength >= O_pipe
    O_ct = O_ct + 1
    segCount = segCount + 1
    desLength = desLength - O_pipe
    If segCount >= 2 Then
        desLength = desLength - CS_Con + Threadin + Threadin
    End If
Wend
While desLength >= P_pipe
    P_ct = P_ct + 1
    segCount = segCount + 1
    desLength = desLength - P_pipe
    If segCount >= 2 Then
        desLength = desLength - CS_Con + Threadin + Threadin
    End If
Wend
While desLength >= Q_pipe
    Q_ct = Q_ct + 1
    segCount = segCount + 1
    desLength = desLength - Q_pipe
    If segCount >= 2 Then
        desLength = desLength - CS_Con + Threadin + Threadin
    End If
Wend
While desLength >= R_pipe
    R_ct = R_ct + 1
    segCount = segCount + 1
    desLength = desLength - R_pipe
    If segCount >= 2 Then
        desLength = desLength - CS_Con + Threadin + Threadin
    End If
Wend
While desLength >= S_pipe
    S_ct = S_ct + 1
    segCount = segCount + 1
    desLength = desLength - S_pipe
    If segCount >= 2 Then
        desLength = desLength - CS_Con + Threadin + Threadin
    End If
Wend
While desLength >= T_pipe
    T_ct = T_ct + 1
    segCount = segCount + 1
    desLength = desLength - T_pipe
    If segCount >= 2 Then
        desLength = desLength - CS_Con + Threadin + Threadin
    End If
Wend
While desLength >= U_pipe
    U_ct = U_ct + 1
    segCount = segCount + 1
    desLength = desLength - U_pipe
    If segCount >= 2 Then
        desLength = desLength - CS_Con + Threadin + Threadin
    End If
Wend
While desLength >= V_pipe
    V_ct = V_ct + 1
    segCount = segCount + 1
    desLength = desLength - V_pipe
    If segCount >= 2 Then
        desLength = desLength - CS_Con + Threadin + Threadin
    End If
Wend
While desLength >= W_pipe
    W_ct = W_ct + 1
    segCount = segCount + 1
    desLength = desLength - W_pipe
    If segCount >= 2 Then
        desLength = desLength - CS_Con + Threadin + Threadin
    End If
Wend
While desLength >= X_pipe
    X_ct = X_ct + 1
    segCount = segCount + 1
    desLength = desLength - X_pipe
    If segCount >= 2 Then
        desLength = desLength - CS_Con + Threadin + Threadin
    End If
Wend
While desLength >= Y_pipe
    Y_ct = Y_ct + 1
    segCount = segCount + 1
    desLength = desLength - Y_pipe
    If segCount >= 2 Then
        desLength = desLength - CS_Con + Threadin + Threadin
    End If
Wend
While desLength >= Z_pipe
    Z_ct = Z_ct + 1
    segCount = segCount + 1
    desLength = desLength - Z_pipe
    If segCount >= 2 Then
        desLength = desLength - CS_Con + Threadin + Threadin
    End If
Wend
While desLength > 0
    FULLY_ct = FULLY_ct + 1
    segCount = segCount + 1
    desLength = desLength - FULLY_pipe
    If segCount >= 2 Then
        desLength = desLength - CS_Con + Threadin + Threadin
    End If
Wend

CS_Con_ct_p = segCount - 1
CS_Con_ct_tot = CS_Con_ct_tot + CS_Con_ct_p

A_ct_tot = A_ct + A_ct_tot
B_ct_tot = B_ct + B_ct_tot
C_ct_tot = C_ct + C_ct_tot
D_ct_tot = D_ct + D_ct_tot
E_ct_tot = E_ct + E_ct_tot
F_ct_tot = F_ct + F_ct_tot
G_ct_tot = G_ct + G_ct_tot
H_ct_tot = H_ct + H_ct_tot
I_ct_tot = I_ct + I_ct_tot
J_ct_tot = J_ct + J_ct_tot
K_ct_tot = K_ct + K_ct_tot
L_ct_tot = L_ct + L_ct_tot
M_ct_tot = M_ct + M_ct_tot
N_ct_tot = N_ct + N_ct_tot
O_ct_tot = O_ct + O_ct_tot
P_ct_tot = P_ct + P_ct_tot
Q_ct_tot = Q_ct + Q_ct_tot
R_ct_tot = R_ct + R_ct_tot
S_ct_tot = S_ct + S_ct_tot
T_ct_tot = T_ct + T_ct_tot
U_ct_tot = U_ct + U_ct_tot
V_ct_tot = V_ct + V_ct_tot
W_ct_tot = W_ct + W_ct_tot
X_ct_tot = X_ct + X_ct_tot
Y_ct_tot = Y_ct + Y_ct_tot
Z_ct_tot = Z_ct + Z_ct_tot
FULLY_ct_tot = FULLY_ct + FULLY_ct_tot

Range("C3") = CS_Con_ct
Range("C4") = CS_Un_ct
Range("C5") = CS_90deg_ct
Range("C6") = CS_Tee_ct
Range("C7") = A_ct
Range("C8") = B_ct
Range("C9") = C_ct
Range("C10") = D_ct
Range("C11") = E_ct
Range("C12") = F_ct
Range("C13") = G_ct
Range("C14") = H_ct
Range("C15") = I_ct
Range("C16") = J_ct
Range("C17") = K_ct
Range("C18") = L_ct
Range("C19") = M_ct
Range("C20") = N_ct
Range("C21") = O_ct
Range("C22") = P_ct
Range("C23") = Q_ct
Range("C24") = R_ct
Range("C25") = S_ct
Range("C26") = T_ct
Range("C27") = U_ct
Range("C28") = V_ct
Range("C29") = W_ct
Range("C30") = X_ct
Range("C31") = Y_ct
Range("C32") = Z_ct
Range("C33") = FULLY_ct

Range("D3") = CS_Con_ct_tot
Range("D4") = CS_Un_ct_tot
Range("D5") = CS_90deg_ct_tot
Range("D6") = CS_Tee_ct_tot
Range("D7") = A_ct_tot
Range("D8") = B_ct_tot
Range("D9") = C_ct_tot
Range("D10") = D_ct_tot
Range("D11") = E_ct_tot
Range("D12") = F_ct_tot
Range("D13") = G_ct_tot
Range("D14") = H_ct_tot
Range("D15") = I_ct_tot
Range("D16") = J_ct_tot
Range("D17") = K_ct_tot
Range("D18") = L_ct_tot
Range("D19") = M_ct_tot
Range("D20") = N_ct_tot
Range("D21") = O_ct_tot
Range("D22") = P_ct_tot
Range("D23") = Q_ct_tot
Range("D24") = R_ct_tot
Range("D25") = S_ct_tot
Range("D26") = T_ct_tot
Range("D27") = U_ct_tot
Range("D28") = V_ct_tot
Range("D29") = W_ct_tot
Range("D30") = X_ct_tot
Range("D31") = Y_ct_tot
Range("D32") = Z_ct_tot
Range("D33") = FULLY_ct_tot

continue = MsgBox("Do you have another segment?", vbQuestion + vbYesNo)
Wend

Call PresentThreadedCalc

End Sub

The code always uses the longest pipe segment possible and iterates down through to see which is the longest segment that fits.

If no whole pipe may be used but there is still length, it uses a "fully threaded" segment which finishes out the length.

Could you explain a little more about how it's supposed to work? What is the final output, and what carries forward from each stage? — Graham
– Graham, Commented Jun 16, 2017 at 13:01
See edit. The program fills out this table, telling the user which pipe lengths and components will fulfill the desired measurements. — Tanner
– Tanner, Commented Jun 16, 2017 at 13:23
How does the program handle multiple solutions to same length? Example: If I want 80" pipe then it could be 1 x 72" + 1 x 8" pipe OR 4 x 20" pipe OR 1 x 60" + 1 x 20" pipe... — Alex P
– Alex P, Commented Jun 16, 2017 at 13:40
I've added the full code. All connector lengths are specified now. — Tanner
– Tanner, Commented Jun 16, 2017 at 13:54

CMArg · Accepted Answer · 2017-06-16 15:37:47Z

1

As @Graham said, the logic is not easily undestandable. However, it might be usufull to store values in an Array or a Dictionary. One advantage of a dictionary is that is easy to know if an element exist in it (d.exist(xx)). The following code will load pipe lenghts to a dictionary, as well as the row of each one. Data is supposed to be in worksheet "Data", starting in row 8. As well as a Dictionary with pipe lenghts, you can create another (say Connectors) with keys Connector, Tee, Union and so on, and for each of those keys add an element when needed (similar to the way I'm adding row number in the code below). Something like Components.Item("Connector") = Components.Item("Connector")+1).

Once you have data in dictionaries, you can perform your comparisons.

Edited Find the nearer pipe according to input

Private Sub CommandButton1_Click()
    Dim desLength As Long
    Dim lLastRow As Long
    Dim rMyRange As Range
    Dim rMyCell As Range
    Dim v As Variant

    desLength = Application.InputBox("Enter the desired end to center or center to center length", Type:=1)
    lLastRow = Worksheets("Data").Cells(8, 1).End(xlDown).Row '"pipes" starting at row 8
    Set rMyRange = Worksheets("Data").Range("A8:A" & lLastRow) '"pipes" starting at row 8
    Set d = CreateObject("scripting.dictionary")

    For Each rMyCell In rMyRange.Cells
        ThePipeLenght = Split(rMyCell.Value, """")
        If Not d.Exists(ThePipeLenght(0)) Then     'If not in dictionary, add it
            d.Add ThePipeLenght(0), rMyCell.Row
        End If
    Next rMyCell

    'write dictionary just to see its contents
    i = 1
    For Each v In d.Keys
        Worksheets("Data").Cells(i + 1, 6) = v
        Worksheets("Data").Cells(i + 1, 7) = d.Item(v)
        i = i + 1
    Next

    'Check if input matches any length.
    'If not, find the nearer one
    If d.Exists(CStr(desLength)) Then
        Worksheets("Data").Cells(d.Item(CStr(desLength)), 3) = "This One"
    Else
        DifferencePre = 200
        For Each v In d.Keys
            If v < desLength Then
                Difference = desLength - v
                If Difference < DifferencePre Then
                    WhichOne = d.Item(v)
                    DifferencePre = Difference
                End If
            End If
        Next
        Worksheets("Data").Cells(WhichOne, 3) = "Not exactly. This is the nearer"
    End If
End Sub

edited Jun 16, 2017 at 15:37

answered Jun 16, 2017 at 14:44

CMArg

1,5973 gold badges14 silver badges32 bronze badges

Sign up to request clarification or add additional context in comments.

3 Comments

Tanner Over a year ago

I selected this as the answer because I ended up using dictionaries. My final code is very different, but thanks for the great tips!

CMArg Over a year ago

Glad it helps. Anyway, take into account that is perfectly legal in this site to post an answer to your own question.

Tanner Over a year ago

my code is now posted as the answer. Let me know what you think of it.

Alex P · Accepted Answer · 2017-06-16 20:43:56Z

I've had a go at simplifying this for you. Do read my notes at the end:

Public arrayIndex As Integer
Const Threadin = 0.563

Sub GetComponents()
    Dim inputLength As Double, inputEnd1 As String, inputEnd2 As String, startLength As Double

    inputLength = Application.InputBox("Enter the desired end to center or center to center length", Type:=1)
    inputEnd1 = Application.InputBox("Enter End1 Connection (none, Connector, Union, 90deg, or Tee)", Type:=2)
    inputEnd2 = Application.InputBox("Enter End2 Connection (none, Connector, Union, 90deg, or Tee)", Type:=2)

    startLength = inputLength

    If VBA.Len(inputEnd1) <> 0 Then
        MapToComponentList inputEnd1
        startLength = inputLength - GetEndSize(inputEnd1) + Threadin
    End If

    If VBA.Len(inputEnd2) <> 0 Then
        MapToComponentList inputEnd2
        startLength = startLength - GetEndSize(inputEnd2) + Threadin
    End If

    GetRodComponents startLength

End Sub

Function GetEndSize(endType As String) As Double
    Dim size As Double

    If VBA.LCase(endType) = "connector" Then
        size = 2.53
    ElseIf VBA.LCase(endType) = "union" Then
        size = 3#
    ElseIf VBA.LCase(endType) = "90deg" Then
        size = 2.25
    ElseIf VBA.LCase(endType) = "tee" Then
        size = 2.25
    End If

    GetEndSize = size
End Function

Sub MapToComponentList(item As Variant)
    If Not IsNumeric(item) Then
        If VBA.LCase(item) = "connector" Then
            Range("D3") = Range("D3") + 1
        ElseIf VBA.LCase(item) = "union" Then
            Range("D4") = Range("D4") + 1
        ElseIf VBA.LCase(item) = "90deg" Then
            Range("D5") = Range("D5") + 1
        ElseIf VBA.LCase(item) = "tee" Then
            Range("D6") = Range("D6") + 1
        End If
    Else
            Range("D" & item + 7) = Range("D" & item + rowOffset) + 1
    End If
End Sub

Sub GetRodComponents(length As Double)
    Dim pipeSizes() As Variant, arrayLength As Integer

    pipeSizes = Array(126, 72, 60, 48, 36, 24, 22, 20, 18, 16, 14, 12, 11, 10, 9, 8, 7, 6.5, 6, 5.5, 5, 4.5, 4, 3.5, 3, 2.5, 2)
    arrayLength = Application.CountA(pipeSizes) - 1

    If length < pipeSizes(arrayLength) Then
        If length <> 0 Then
            Range("D33") = Range("D33") + 1
        End If
        arrayIndex = 0
        Exit Sub
    Else
        If length >= pipeSizes(arrayIndex) Then
            Range("D" & arrayIndex + 7) = Range("D" & arrayIndex + 7) + 1
            GetRodComponents length - pipeSizes(arrayIndex)
        Else
            arrayIndex = arrayIndex + 1
            GetRodComponents length
        End If
    End If
End Sub

Notes:

GetComponents is the entry point for the code.
GetEndSize is helper that gets the end size to modify the length
MapToComponentList is a helper to map end types and rod lengths to the spreadsheet
GetRodComponents is a recursive procedure to figure what lengths of rod are required given an initial starting length
The code assumes your s/sheet is as per your uploaded image

HTH

Graham · Accepted Answer · 2017-06-16 14:02:24Z

0

I'd suggest using the worksheet itself a little more, as the logic seems to be the same in every row. It's a little tough for me to understand the exact logic in order to write the code, but this is the basic framework I'd use.

dim rowIndex as Integer
dim lengthColumn as Integer
dim segmentsColumn as Integer

lengthColumn = 2
segmentsColumne = 3

For rowIndex = 3 to 20

     ' calculate legnth here
     activeWorksheet.cells(rowIndex, lengthColumn).value = ...

     ' calculate segments here
     activeWorksheet.cells(rowIndex, segmentsColumn).value = ...

Next

You could also dynamically seek the end of the range with a while loop that tests for the existence of a blank cell.

answered Jun 16, 2017 at 14:02

Graham

7,86020 gold badges67 silver badges92 bronze badges

Comments

Dy.Lee · Accepted Answer · 2017-06-16 16:29:36Z

The code can be changed like this code.

Sub ThreadedPipeCalc2()

Dim desLength As Single, end1 As String, end2 As String
Dim none As Single
Dim segCount As Integer
Dim CountRedux As Boolean, continue As Integer
Dim n As Integer, z As Integer, k As Integer, m
continue = 6
Dim vEnd1(1 To 7), vEnd2(1 To 7)

none = 0
vEnd1(1) = 2.53 'CS_Con = 2.53
vEnd2(1) = 2.5 'SS_Con = 2.5
vEnd1(2) = 3 'CS_Un = 3
vEnd2(2) = 2.85 'SS_Un = 2.85
vEnd1(3) = 2.25 'CS_90deg = 2.25
vEnd2(3) = 2.28 'SS_90deg = 2.28
vEnd1(4) = 2.25 'CS_Tee = 2.25
vEnd2(4) = 2.26 'SS_Tee = 2.26
vEnd1(5) = 1 'CS_Flange = 1
vEnd2(5) = 1 'SS_Flange = 1
SS_Flang_red = 1.1875
SS_Cap = 1.77
Threadin = 0.563

Dim myPipe(1 To 27)
myPipe(1) = 126 'a_pipe
myPipe(2) = 72  'b_pipe
myPipe(3) = 60
myPipe(4) = 48
myPipe(5) = 36
myPipe(6) = 24
myPipe(7) = 22
myPipe(8) = 20
myPipe(9) = 18
myPipe(10) = 16
myPipe(11) = 14
myPipe(12) = 12
myPipe(13) = 11
myPipe(14) = 10
myPipe(15) = 9
myPipe(16) = 8
myPipe(17) = 7
myPipe(18) = 6.5
myPipe(19) = 6
myPipe(20) = 5.5
myPipe(21) = 5
myPipe(22) = 4.5
myPipe(23) = 4
myPipe(24) = 3.5
myPipe(25) = 3
myPipe(26) = 2.5
myPipe(27) = 2

While continue = 6

segCount = 0
Range("C3:C32").Value = 0

Dim myCt(1 To 27)
' cs_con_ct .. A_ct,...,FULLY_cy

Dim vTot
vTot = Range("D3").Resize(27)

desLength = Application.InputBox("Enter the desired end to center or center to center length", Type:=1)
end1 = Application.InputBox("Enter End1 Connection (none, Connector, Union, 90deg, or Tee)", Type:=2)
If end1 = Range("A1") Then
    CountRedux = True
Else
    CountRedux = False
End If
end2 = Application.InputBox("Enter End2 Connection (none, Connector, Union, 90deg, or Tee)", Type:=2)

Range("A1") = end2
Range("B2") = desLength

Dim myEnd

myEnd = Array("Connector", "Union", "90deg", "Tee")
n = 0
For Each m In myEnd
    n = n + 1
    If end1 = m Then
        k = n
    End If
    If end2 = m Then
        z = n
    End If
Next m

    myCt(k) = myCt(k) + 1
    If CountRedux = False Then vTot(k, 1) = vTot(k, 1) + 1
    desLength = desLength - vEnd1(k) + Threadin

    myCt(z) = myCt(z) + 1
    vTot(z, 1) = vTot(z, 1) + 1
    desLength = desloength - vEnd1(k) + Threadin

    For i = 2 To UBound(myPipe)
        While desLength > myPipe(i)
            myCt(i) = myCt(i) + 1
            segCount = segcout + 1
            desLength = desLength - myPipe(i)
            If segCount >= 2 Then
               desLength = desLength - vEnd1(k) + Threadin + Threadin
            End If
        Wend
    Next i

cs_con_ct_p = segCount - 1
vTot(1, 1) = vTot(1, 1) + cs_con_ct_p

For i = 5 To UBound(vTot, 1)
    vTot(i, 1) = myCt(i) + vTot(i, 1) 'A_ct_tot ~ Fully_ct_tot
Next i
Range("c3").Resize(27) = WorksheetFunction.Transpose(myCt)
Range("d3").Resize(27) = vTot

continue = MsgBox("Do you have another segment?", vbQuestion + vbYesNo)
Wend

'Call PresentThreadedCalc

End Sub

Tanner · Accepted Answer · 2017-06-21 18:48:05Z

I continued working on this code and ended up with this. (It's declared explicit at the top of the module.)

Sub ThreadedPipeCalcNEW()
    On Error Resume Next

    ResetThreadedCalc

    'above line needed for input validation
    'dimension variables and set constants
    Dim j As Variant, k As Variant, dictCon As Object, dictPipe As Object
    Dim desLength As Single, desiredLength As Single, end1 As String, end2 As String
    Dim matTypes As Variant, myMaterial As String
    Dim continue As Integer, whileCount As Integer, conLooper As Integer, pipLooper As Integer
    Dim cell As Variant, lastRow As Variant
    Const Threadin = 0.563 'this is how far a pipe threads into a fitting (9/16 of an inch)

    'initialize continue so that main while loop begins properly
    continue = vbYes
    'initialize material types
    matTypes = Array("carbon", "stainless")
    'initialize dictionaries
    Set dictCon = CreateObject("Scripting.Dictionary")
    Set dictPipe = CreateObject("Scripting.Dictionary")
    dictCon.CompareMode = vbTextCompare 'non-case-sensitive comparison
    dictPipe.CompareMode = vbTextCompare 'non-case-sensitive comparison

    'populate connector dictionary
    dictCon.Add Key:="carbonConnector", Item:=2.53
    dictCon.Add Key:="carbonUnion", Item:=3
    dictCon.Add Key:="carbon90Deg", Item:=2.25
    dictCon.Add Key:="carbon45Deg", Item:=0
    dictCon.Add Key:="carbonTee", Item:=2.25
    dictCon.Add Key:="carbonFlange", Item:=1
    dictCon.Add Key:="stainlessConnector", Item:=2.5
    dictCon.Add Key:="stainlessUnion", Item:=2.85
    dictCon.Add Key:="stainless90Deg", Item:=2.28
    dictCon.Add Key:="stainless45Deg", Item:=0
    dictCon.Add Key:="stainlessTee", Item:=2.26
    dictCon.Add Key:="stainlessFlange", Item:=1
    dictCon.Add Key:="stainlessReducingflange", Item:=1.1875
    dictCon.Add Key:="none", Item:=0

    'populate pipe dictionary
    dictPipe.Add Key:="A_pipe", Item:=72
    dictPipe.Add Key:="B_pipe", Item:=60
    dictPipe.Add Key:="C_pipe", Item:=48
    dictPipe.Add Key:="D_pipe", Item:=36
    dictPipe.Add Key:="E_pipe", Item:=30
    dictPipe.Add Key:="F_pipe", Item:=24
    dictPipe.Add Key:="G_pipe", Item:=18
    dictPipe.Add Key:="H_pipe", Item:=12
    dictPipe.Add Key:="I_pipe", Item:=11
    dictPipe.Add Key:="J_pipe", Item:=10
    dictPipe.Add Key:="K_pipe", Item:=9
    dictPipe.Add Key:="L_pipe", Item:=8
    dictPipe.Add Key:="M_pipe", Item:=7
    dictPipe.Add Key:="N_pipe", Item:=6
    dictPipe.Add Key:="O_pipe", Item:=5.5
    dictPipe.Add Key:="P_pipe", Item:=5
    dictPipe.Add Key:="Q_pipe", Item:=4.5
    dictPipe.Add Key:="R_pipe", Item:=4
    dictPipe.Add Key:="S_pipe", Item:=3.5
    dictPipe.Add Key:="T_pipe", Item:=3
    dictPipe.Add Key:="U_pipe", Item:=2.5
    dictPipe.Add Key:="FULLY_pipe", Item:=0 'really a fully threaded pipe nipple is two inches, but it needs to be used whenever there is a remainder distance

    'allows user to input material type for whole system
    While IsError(Application.WorksheetFunction.Match(Trim(myMaterial), matTypes, 0))
        myMaterial = Application.InputBox("Enter Material (carbon or stainless)", Type:=2)
        If myMaterial = "False" Then Exit Sub 'user clicked cancel,so exit program
        myMaterial = Trim(myMaterial)
    Wend

    'begin while loop to accept user input and run calculations
    While continue = vbYes
        'on second loop end1 will be assigned as the old end2
        end1 = end2
        'end2 will be reset to blank so that it is again set by user input
        end2 = ""

        'initialize for loop component and pipe counters
        'this allows the proper cell tallies to be added
        conLooper = 2 'set this to the connector row
        pipLooper = 16 'set this to the first row of pipe

        'allows user to input connection types while checking for errors
        'and ending the program if cancel button is pressed
        While IsError(Application.WorksheetFunction.Match(Trim(end1), dictCon.Keys, 0))
            end1 = Application.InputBox("Enter End1 Connection" & vbCrLf & vbCrLf & _
            "(none, connector, union, 90deg, 45deg, tee, flange, or reducingflange).", Type:=2)
            If end1 = "False" Then Exit Sub 'user clicked cancel,so exit program
            If end1 <> "none" Then
                end1 = Application.Proper(end1)
                end1 = myMaterial & end1
            End If
        Wend

        'accepts user input for length of segment center/end to center/end
        desiredLength = Application.InputBox("Enter the desired end to center or center to center length in INCHES." _
                                        & vbCrLf & vbCrLf & "The previous length was " & CStr(desiredLength) & ".", Type:=1)
        desLength = desiredLength 'passes input to a dynamic number for rest of program
                                  'this way, the previously entered length can be shown when loop run more than once

        'allows user to input connection types while checking for errors
        'and ending the program if cancel button is pressed
        While IsError(Application.WorksheetFunction.Match(Trim(end2), dictCon.Keys, 0))
            end2 = Application.InputBox("Enter End2 Connection" & vbCrLf & vbCrLf & _
            "(none, connector, union, 90deg, 45deg, tee, flange, or reducingflange)." _
            & vbCrLf & vbCrLf & "The previous end was " & end1 & ".", Type:=2)
            If end2 = "False" Then Exit Sub 'user clicked cancel,so exit program
            If end2 <> "none" Then
                end2 = Application.Proper(end2)
                end2 = myMaterial & end2
            End If
        Wend

        'iterate through keys, check ends, add to counts, and alter desLength (aka desiredLength) by connector dimensions (accounting for threadin)
        For Each j In dictCon.Keys
            If end1 = j And whileCount = 0 Then
                Worksheets("Sheet1").Range("B" & CStr(conLooper)).Value = Worksheets("Sheet1").Range("B" & CStr(conLooper)).Value + 1
                desLength = desLength - dictCon.Item(j) + Threadin
            End If
            If end1 = j And whileCount > 0 Then 'do not add to the component count if the end has been accounted for as end1/end2 already
                desLength = desLength - dictCon.Item(j) + Threadin
            End If
            If end2 = j Then 'second end is always considered new and is thus added to the count
                Worksheets("Sheet1").Range("B" & CStr(conLooper)).Value = Worksheets("Sheet1").Range("B" & CStr(conLooper)).Value + 1
                desLength = desLength - dictCon.Item(j) + Threadin
            End If
            conLooper = conLooper + 1
        Next j

        'iterate through keys, handle fully threaded pipe specially, otherwise add pipe and modfify desiredLength according to pipe length
        'account for the addition of connectors when more than one pipe piece is used from one connector to another
        For Each k In dictPipe.Keys
            While desLength - 1.404 >= dictPipe.Item(k)
                If k = "FULLY_pipe" Then
                    Worksheets("Sheet1").Range("B" & CStr(pipLooper)).Value = Worksheets("Sheet1").Range("B" & CStr(pipLooper)).Value + 1
                    desLength = desLength - 2
                Else
                    Worksheets("Sheet1").Range("B" & CStr(pipLooper)).Value = Worksheets("Sheet1").Range("B" & CStr(pipLooper)).Value + 1
                    desLength = desLength - dictPipe.Item(k)
                    If desLength <> 0 Then
                        If myMaterial = "carbon" Then
                            Worksheets("Sheet1").Range("B2").Value = Worksheets("Sheet1").Range("B2").Value + 1 'hardcoded position of connector row
                        Else
                            Worksheets("Sheet1").Range("B8").Value = Worksheets("Sheet1").Range("B8").Value + 1 'hardcoded position of connector row
                        End If
                        desLength = desLength - dictCon.Item(myMaterial & "Connector") + (2 * Threadin)
                    End If
                End If
            Wend
            pipLooper = pipLooper + 1
        Next k

        'if there is any remaining pipe length, take care of it with a fully threaded piece; this ensures the pipe is always slightly too long instead of too short
        If desLength > 0 And desLength <= 1.404 Then
            Worksheets("Sheet1").Range("B" & CStr(pipLooper - 1)).Value = Worksheets("Sheet1").Range("B" & CStr(pipLooper - 1)).Value + 1
        End If

        'run again until user has no more segments
        'this allows the program to build out a whole BOM
        continue = MsgBox("Do you have another segment?", vbQuestion + vbYesNo)

        'add one to the loop count, indicating if the connector count
        'must be modified since end1 is being assigned as the previous end2
        whileCount = whileCount + 1
    Wend

    'find used range; ensures code is easier to edit
    lastRow = Range("B" & Rows.Count).End(xlUp).Row

    'hide rows with unneeded components
    For Each cell In Worksheets("Sheet1").Range("B2:B" & CStr(lastRow)).Cells
        If cell.Value = 0 Then cell.EntireRow.Hidden = True
    Next

End Sub

The reset subfunction is as follows

Sub ResetThreadedCalc()

    Dim cell2 As Variant, lastRow2 As Variant

    'find used range; ensures code is easier to edit
    lastRow2 = Worksheets("Sheet1").UsedRange.Rows.Count

    'unhide rows or set values to zero
    For Each cell2 In Worksheets("Sheet1").Range("B2:B" & CStr(lastRow2)).Cells
        If cell2.Value = 0 Then
            cell2.EntireRow.Hidden = False
        Else
            cell2.Value = 0
        End If
    Next

End Sub

And the sheet was modified to be

Please let me know your thoughts on if this can be made any better! I'm happy to continue improving.

As always, thanks for all your help, suggestions, and time.

Cheers, Tanner

Collectives™ on Stack Overflow

Long Code needs array

5 Answers 5

3 Comments

Comments

Comments

Comments

Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

5 Answers 5

3 Comments

Comments

Comments

Comments

Comments

Your Answer

Sign up or log in

Post as a guest

Related