' ===== STANDARD MODULE CODE =====
' Insert > Module > Paste this code
Dim userChoices As Object
Sub CalculateDuctWeight()
Dim ws As Worksheet
Dim lastRow As Long, i As Long, j As Long
Dim width As Double, ductItem As String, itemKey As String
Dim C As Double, D As Double, E As Double, G As Double, H As Double
Dim area As Double, weight As Double, totalWeight As Double
Dim fittingList() As String, equationList() As String
Dim fittingCount As Integer, matchIndex As Integer
Dim summaryMsg As String, key As Variant
Set userChoices = CreateObject("[Link]")
Set ws = ActiveSheet
' Unprotect the worksheet with password "Naira"
[Link] "Naira"
' Build fitting list and equations from Column O and P
fittingCount = 0
ReDim fittingList(1 To 20)
ReDim equationList(1 To 20)
For j = 2 To 20
If [Link](j, "O").Value <> "" And [Link](j, "O").Value <> "Fitting"
Then
fittingCount = fittingCount + 1
fittingList(fittingCount) = Trim([Link](j, "O").Value)
equationList(fittingCount) = Trim([Link](j, "P").Value)
End If
Next j
lastRow = [Link]([Link], "B").End(xlUp).Row
' Auto-number Column A
Call AutoNumberColumn(ws, lastRow)
' Clear previous results
If lastRow > 1 Then [Link]("F2:I" & lastRow).ClearContents
[Link]("L12").ClearContents
' Loop through each row
For i = 2 To lastRow
If Trim([Link](i, "B").Value) = "" Then GoTo NextRow
If IsNumeric([Link](i, "C").Value) Then
width = [Link](i, "C").Value
' Lookup Gauge and Thickness
For j = 2 To 6
If IsNumeric([Link](j, "M").Value) Then
If width <= [Link](j, "M").Value Then
[Link](i, "F").Value = [Link](j, "K").Value
[Link](i, "G").Value = [Link](j, "L").Value
Exit For
End If
End If
Next j
' If no match found, use last row
If [Link](i, "F").Value = "" Then
[Link](i, "F").Value = [Link](6, "K").Value
[Link](i, "G").Value = [Link](6, "L").Value
End If
' Get duct item and dimensions
ductItem = Trim([Link](i, "B").Value)
C = [Link](i, "C").Value
D = [Link](i, "D").Value
E = [Link](i, "E").Value
' Find matching fitting type
matchIndex = 0
For j = 1 To fittingCount
If UCase(ductItem) = UCase(fittingList(j)) Then
matchIndex = j
Exit For
End If
Next j
' If not found in Column O, ask user or use stored choice
If matchIndex = 0 Then
itemKey = UCase(ductItem)
If [Link](itemKey) Then
matchIndex = userChoices(itemKey)
Else
matchIndex = ShowFittingSelection(ductItem, i, fittingList,
equationList, fittingCount)
If matchIndex = 0 Then
' User cancelled - exit entire calculation
Set userChoices = Nothing
Exit Sub
End If
[Link] itemKey, matchIndex
End If
End If
' Calculate area using equation from Column P
area = EvaluateEquation(equationList(matchIndex), C, D, E)
If area > 0 Then
H = area / 1000000 ' Convert mm² to m²
[Link](i, "H").Value = Round(H, 4)
G = [Link](i, "G").Value
If IsNumeric(G) And G > 0 Then
weight = (7850 * G * H) / 1000
[Link](i, "I").Value = Round(weight, 2)
End If
End If
End If
NextRow:
Next i
' Calculate total weight
totalWeight = 0
For i = 2 To lastRow
If IsNumeric([Link](i, "I").Value) Then
totalWeight = totalWeight + [Link](i, "I").Value
End If
Next i
[Link]("L12").Value = Round(totalWeight, 2)
' Show summary
summaryMsg = "Calculation completed!" & vbCrLf & "Total Weight: " &
Round(totalWeight, 2) & " KG"
If [Link] > 0 Then
summaryMsg = summaryMsg & vbCrLf & vbCrLf & "User choices applied:"
For Each key In [Link]
summaryMsg = summaryMsg & vbCrLf & " • " & key & " ? " &
fittingList(userChoices(key))
Next key
End If
MsgBox summaryMsg, vbInformation, "Duct Calculator"
' Protect the worksheet again with password "Naira"
[Link] Password:="Naira", AllowFiltering:=True, AllowSorting:=True,
UserInterfaceOnly:=True
Set userChoices = Nothing
End Sub
Sub AutoNumberColumn(ws As Worksheet, lastRow As Long)
Dim i As Long, counter As Long
counter = 1
For i = 2 To lastRow
If [Link](i, "B").Value <> "" Then
[Link](i, "A").Value = counter
counter = counter + 1
Else
[Link](i, "A").ClearContents
End If
Next i
End Sub
Function EvaluateEquation(equation As String, C As Double, D As Double, E As
Double) As Double
Dim formula As String
Dim i As Integer
Dim currentChar As String
Dim nextChar As String
Dim newFormula As String
On Error GoTo ErrorHandler
formula = equation
' Replace multiplication symbols
formula = Replace(formula, "×", "*")
formula = Replace(formula, "x", "*", , , vbTextCompare)
' Add explicit multiplication operators
newFormula = ""
For i = 1 To Len(formula)
currentChar = Mid(formula, i, 1)
If i < Len(formula) Then
nextChar = Mid(formula, i + 1, 1)
Else
nextChar = ""
End If
newFormula = newFormula & currentChar
' Add * between number and (
If IsNumeric(currentChar) And nextChar = "(" Then
newFormula = newFormula & "*"
End If
' Add * between ) and (
If currentChar = ")" And nextChar = "(" Then
newFormula = newFormula & "*"
End If
' Add * between ) and letter (C, D, E)
If currentChar = ")" And (UCase(nextChar) = "C" Or UCase(nextChar) = "D" Or
UCase(nextChar) = "E") Then
newFormula = newFormula & "*"
End If
' Add * between letter and (
If (UCase(currentChar) = "C" Or UCase(currentChar) = "D" Or
UCase(currentChar) = "E") And nextChar = "(" Then
newFormula = newFormula & "*"
End If
' Add * between number and letter
If IsNumeric(currentChar) And (UCase(nextChar) = "C" Or UCase(nextChar) =
"D" Or UCase(nextChar) = "E") Then
newFormula = newFormula & "*"
End If
Next i
formula = newFormula
' Replace variables with actual values
formula = Replace(formula, "C", "(" & CStr(C) & ")", , , vbTextCompare)
formula = Replace(formula, "D", "(" & CStr(D) & ")", , , vbTextCompare)
formula = Replace(formula, "E", "(" & CStr(E) & ")", , , vbTextCompare)
' Evaluate the formula
EvaluateEquation = [Link](formula)
Exit Function
ErrorHandler:
EvaluateEquation = 0
MsgBox "Error evaluating equation: " & equation & vbCrLf & _
"Processed formula: " & formula & vbCrLf & _
"Error: " & [Link], vbExclamation, "Equation Error"
[Link]
End Function
Function ShowFittingSelection(ductItem As String, rowNum As Long, fittingList() As
String, equationList() As String, fittingCount As Integer) As Integer
Dim userInput As String, msg As String, i As Integer
msg = "Row " & rowNum & ": '" & ductItem & "' not found in fitting list." &
vbCrLf & vbCrLf & _
"This choice applies to ALL occurrences of '" & ductItem & "'." & vbCrLf
& vbCrLf & _
"Available fitting types:" & vbCrLf & vbCrLf
For i = 1 To fittingCount
msg = msg & i & " - " & fittingList(i) & " [" & equationList(i) & "]" &
vbCrLf
Next i
msg = msg & vbCrLf & "Enter number (1-" & fittingCount & ") or Cancel:"
userInput = InputBox(msg, "Select Fitting Type - " & ductItem)
If IsNumeric(userInput) Then
If Val(userInput) >= 1 And Val(userInput) <= fittingCount Then
ShowFittingSelection = Val(userInput)
Exit Function
End If
End If
ShowFittingSelection = 0
End Function
Sub ResetCalculations()
Dim ws As Worksheet, lastRow As Long, response As Variant
Set ws = ActiveSheet
lastRow = [Link]([Link], "B").End(xlUp).Row
If lastRow < 2 Then lastRow = 15
response = [Link]( _
"Choose reset option:" & vbCrLf & vbCrLf & _
"Enter 1 = Clear All (Columns A to I)" & vbCrLf & _
"Enter 2 = Clear Results Only (Columns F to I)" & vbCrLf & _
"Click Cancel to cancel" & vbCrLf & vbCrLf & _
"Your choice (1 or 2):", _
"Reset Options", Type:=1)
If response = False Then
Exit Sub
End If
Select Case response
Case 1
If lastRow > 1 Then [Link]("A2:I" & lastRow).ClearContents
[Link]("L12").ClearContents
MsgBox "All data cleared (Columns A to I)!", vbInformation, "Clear All"
Case 2
If lastRow > 1 Then [Link]("F2:I" & lastRow).ClearContents
[Link]("L12").ClearContents
MsgBox "Results cleared (Columns F to I)!", vbInformation, "Clear
Results"
Case Else
MsgBox "Invalid choice. Enter 1 or 2.", vbExclamation, "Invalid Input"
End Select
End Sub