Vba 长代码需要数组
我已经有一段时间没有处理VBA了,我写了一些相当不优雅的东西 有人能建议一种缩短以下代码的方法吗?我想数组可能会有所帮助,但我不知道如何实现它 本规范的目的是构建螺纹管系统,螺纹管必须以相当精确的长度组合。程序始终使用与所需管道长度的剩余量相匹配的最大管道长度 为了使代码尽可能简短,我省略了标注变量和显示结果的部分 提前感谢你的帮助Vba 长代码需要数组,vba,excel,Vba,Excel,我已经有一段时间没有处理VBA了,我写了一些相当不优雅的东西 有人能建议一种缩短以下代码的方法吗?我想数组可能会有所帮助,但我不知道如何实现它 本规范的目的是构建螺纹管系统,螺纹管必须以相当精确的长度组合。程序始终使用与所需管道长度的剩余量相匹配的最大管道长度 为了使代码尽可能简短,我省略了标注变量和显示结果的部分 提前感谢你的帮助 Sub ThreadedPipeCalc() Dim desLength As Single, end1 As String, end2 As String Di
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
代码始终使用可能的最长管段,并向下迭代以查看哪一段最长
如果不能使用整个管道,但仍有长度,则使用“全螺纹”管段来完成长度。我建议多使用工作表本身,因为每一行的逻辑似乎相同。为了编写代码,我很难理解确切的逻辑,但这是我将使用的基本框架
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
您还可以使用while循环动态地寻找范围的终点,该循环测试是否存在空白单元格。正如@Graham所说,逻辑不容易不可靠。但是,通常将值存储在数组或字典中。字典的一个优点是很容易知道其中是否存在元素(
d.exist(xx)
)。下面的代码将管道长度以及每个管道的行加载到字典中。数据应该在工作表“数据”中,从第8行开始。除了具有管道长度的字典之外,您还可以创建另一个(例如连接器
)字典,其中包含键连接器
、三通
、联合
等,并在需要时为每个键添加一个元素(类似于我在下面代码中添加行号的方式)。类似于Components.Item(“连接器”)=Components.Item(“连接器”)+1)
一旦字典中有了数据,就可以进行比较了
已编辑根据输入查找较近的管道
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
Private子命令按钮1\u单击()
长度和长度一样长
昏暗的灯塔一样长
Dim rMyRange As范围
变暗rMyCell作为范围
Dim v作为变体
desLength=Application.InputBox(“输入所需的端到中心或中心到中心的长度”,类型:=1)
lLastRow=工作表(“数据”)。单元格(8,1)。结束(xlDown)。行“管道”从第8行开始
从第8行开始设置rMyRange=工作表(“数据”)。范围(“A8:A”和“lLastRow”)“管道”
Set d=CreateObject(“scripting.dictionary”)
对于rMyRange.单元格中的每个rMyCell
管道长度=拆分(rMyCell.Value,“”)
如果不存在d(管道长度(0)),则“如果不在字典中,请添加它。”
d、 添加管道长度(0),rMyCell.Row
如果结束
下一个rMyCell
写字典只是为了看看它的内容
i=1
对于每个v In d.键
工作表(“数据”)。单元格(i+1,6)=v
工作表(“数据”)。单元格(i+1,7)=d项(v)
i=i+1
下一个
'检查输入是否匹配任何长度。
“如果没有,就找一个更近的
如果存在d(CStr(desLength)),则
工作表(“数据”)。单元格(d.项(CStr(desLength)),3)=“这一个”
其他的
差值=200
对于每个v In d.键
如果v
该代码可以像此代码一样更改
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
我试过为你简化这件事。请务必阅读我最后的笔记:
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
作为整数的公共数组索引
常数螺纹=0.563
子组件()
Dim inputLength为双精度,InputD1为字符串,InputD2为字符串,startLength为双精度
inputLength=Application.InputBox(“输入所需的端到中心或中心到中心的长度”,类型:=1)
InputD1=Application.InputBox(“输入端1连接(无、连接器、接头、90度或T形)”,类型:=2)
InputD2=Application.InputBox(“输入端2连接(无、连接器、联管、90度或三通)”,类型:=2)
长度=输入长度
如果VBA.Len(输入1)为0,则
MapToComponentList输入1
startLength=inputLength-GetEndSize(InputD1)+Threadin
如果结束
如果VBA.Len(inputEnd2)为0,则
MapToComponentList输入2
惊人长度=惊人长度-GetEndSize(输入2)+螺纹输入
如果结束
GetRodLength
端接头
函数GetEndSize(endType为字符串)为双精度
双倍尺寸
如果VBA.LCase(endType)=“连接器”,则
尺寸=2.53
ElseIf VBA.LCase(endType)=“union”然后
尺寸=3#
ElseIf VBA.LCase(端型)=“90度”,然后
尺寸=2.25
ElseIf VBA.LCase(endType)=“tee”然后
尺寸=2.25
如果结束
GetEndSize=size
端函数
子映射组件列表(项目作为变量)
如果不是数字(项目),则
如果VBA.LCase(项目)=“连接器”,则
范围(“D3”)=范围(“D3”)+1
ElseIf VBA.LCase(项目)=“联合”然后
范围(“D4”)=范围(“D4”)+1
其他VBA.LCase(项目)=“90度”,然后
范围(“D5”)=范围(“D5”)+1
ElseIf VBA.LCase(项目)=“T”然后
范围(“D6”)=范围(“D6”)+1
如果结束
其他的
范围(“D”和项目+7)=范围(“D”和项目+rowOffset)+1
如果结束
端接头
子组件(长度为双精度)
Dim pipeSizes()作为变量,arrayLength作为整数
管道尺寸=阵列(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(管道尺寸)-1
如果长度<管道尺寸(阵列
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
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