How to create a shared procedure
My workbook has 3 very hidden master worksheets, named PANEL, DIST and
LOADS. This workbook is designed for electrical wiring calculation.
The user click on a button to make x copies of PANEL, and name it
Panel1, Panel2, Panel3 ..etc.
In the master worksheet PANEL I have worksheet change code. Here are a
small portion of the codes.
Sub Worksheet_Change(ByVal Target As Range)
Dim whereto As String
whereto = Target.Value
Dim CurrSht As String
CurrSht = ActiveSheet.Name
If Target.Cells.Count 1 Then Exit Sub
If Not Intersect(Target, Range("LeftSide")) Is Nothing Then
If Application.WorksheetFunction.IsText(Target.Value) Then
If Target.Offset(0, 1) = "X" Then
If SheetExists(whereto) = "True" Then
Worksheets(whereto).Range("Transformer") = CurrSht
Worksheets(whereto).Range("sourceXfmrKVA") = Target.Offset(-1,
0)
Worksheets(CurrSht).Select 'return to original sheet
If Worksheets(whereto).Range("zID") = "PANEL" Then
If Worksheets(whereto).Range("ConfigNum") = 7 Or
Worksheets(whereto).Range("ConfigNum") = 8 Then
If Target.Offset(-1, 32) = 3 Or Target.Offset(-2, 32) = 3
Then GoTo Sloppy 'if 3-pole then obvious can't feed 1-phase panel
If Target.Offset(-1, 32) = 2 Then 'if template is 2-phase
transformer
Worksheets(whereto).Range("HA1stPhase") = Target.Offset(-1,
34) 'Enter 1st Phase (say "B") from panel "HA" in "LA" cell
Range("HA1stPhase")
Worksheets(whereto).Range("HA1stPhase").Offset(1, 0) =
Target.Offset(0, 34) 'Enter 2nd Phase (say "C") from panel "HA" in
"LA" cell Range("HA1stPhase").offset by 1
End If
End If
End If
If Worksheets(whereto).Range("zID") = "DIST" Then
If Target.Offset(-2, 32) = 3 Then
Worksheets(whereto).Range("NumPhase") = "3Ph"
Worksheets(whereto).Range("sourcePhA") = "A":
Worksheets(whereto).Range("sourcePhB") = "B":
Worksheets(whereto).Range("sourcePhC") = "C"
End If
If Target.Offset(-1, 32) = 2 Then
Worksheets(whereto).Range("sourceEqptName") = CurrSht
Worksheets(whereto).Range("NumPhase") = "1Ph"
Worksheets(whereto).Range("sourcePhA").ClearConten ts:
Worksheets(whereto).Range("sourcePhB").ClearConten ts:
Worksheets(whereto).Range("sourcePhC").ClearConten ts
Select Case Target.Offset(-1, 34)
Case "A": Worksheets(whereto).Range("sourcePhA") = "A":
Worksheets(whereto).Range("sourcePhB") = "B"
Case "B": Worksheets(whereto).Range("sourcePhB") = "B":
Worksheets(whereto).Range("sourcePhC") = "C"
Case "C": Worksheets(whereto).Range("sourcePhC") = "C":
Worksheets(whereto).Range("sourcePhA") = "A"
End Select
End If
End If
Else
MsgBox ("Specified panel does not exist !! Your input will be
cleared and replaced with an arbitrary load of 2 KVA.")
Target.Value = 2
End If
End If
End If
End If
‘************ more codes similar to above *******
‘************* there are about 5 pages of codes similar to above
continuing here ****
‘ **********************
‘**********************
End sub
Since every copy of PANEL also carry the 5 sheets of Worksheet-Change
code, this makes the workbook much bigger. On some of our projects, we
easily have 20 or more copies of PANEL, therefore there would be more
than 20 x 5 = 100 pages of the same code in those copies of PANEL
worksheets. Similar problem with the master DIST worksheet.
Here is my attempt to make it smaller by creating a shared procedure
called by each copy of PANEL.
Sub Worksheet_Change(ByVal Target As Range)
' Call a shared procedure.PanelChanges
Dim whereto As String
whereto = Target.Value
Dim CurrSht As String
CurrSht = ActiveSheet.Name
If Target.Cells.Count 1 Then Exit Sub
Dim rCell as range
Set rCell=Target
PanelChanges Target ‘call a shared procedure
End Sub
Sub PanelChanges(rCell as Range)
‘shared procedure for all copies of PANEL
If Not Intersect(rCell, Range("LeftSide")) Is Nothing Then
If Application.WorksheetFunction.IsText(rCell.Value) Then
If rCell.Offset(0, 1) = "X" Then
If SheetExists(whereto) = "True" Then
Worksheets(whereto).Range("Transformer") = CurrSht
Worksheets(whereto).Range("sourceXfmrKVA") = rCell.Offset(-1,
0)
Worksheets(CurrSht).Select 'return to original sheet
If Worksheets(whereto).Range("zID") = "PANEL" Then
If Worksheets(whereto).Range("ConfigNum") = 7 Or
Worksheets(whereto).Range("ConfigNum") = 8 Then
If rCell.Offset(-1, 32) = 3 Or rCell.Offset(-2, 32) = 3 Then
GoTo Sloppy 'if 3-pole then obvious can't feed 1-phase panel
If rCell.Offset(-1, 32) = 2 Then 'if template is 2-phase
transformer
Worksheets(whereto).Range("HA1stPhase") = rCell.Offset(-1,
34) 'Enter 1st Phase (say "B") from panel "HA" in "LA" cell
Range("HA1stPhase")
Worksheets(whereto).Range("HA1stPhase").Offset(1, 0) =
rCell.Offset(0, 34) 'Enter 2nd Phase (say "C") from panel "HA" in "LA"
cell Range("HA1stPhase").offset by 1
End If
End If
End If
If Worksheets(whereto).Range("zID") = "DIST" Then
If rCell.Offset(-2, 32) = 3 Then
Worksheets(whereto).Range("NumPhase") = "3Ph"
Worksheets(whereto).Range("sourcePhA") = "A":
Worksheets(whereto).Range("sourcePhB") = "B":
Worksheets(whereto).Range("sourcePhC") = "C"
End If
If rCell.Offset(-1, 32) = 2 Then
Worksheets(whereto).Range("sourceEqptName") = CurrSht
Worksheets(whereto).Range("NumPhase") = "1Ph"
Worksheets(whereto).Range("sourcePhA").ClearConten ts:
Worksheets(whereto).Range("sourcePhB").ClearConten ts:
Worksheets(whereto).Range("sourcePhC").ClearConten ts
Select Case rCell.Offset(-1, 34)
Case "A": Worksheets(whereto).Range("sourcePhA") = "A":
Worksheets(whereto).Range("sourcePhB") = "B"
Case "B": Worksheets(whereto).Range("sourcePhB") = "B":
Worksheets(whereto).Range("sourcePhC") = "C"
Case "C": Worksheets(whereto).Range("sourcePhC") = "C":
Worksheets(whereto).Range("sourcePhA") = "A"
End Select
End If
End If
Else
MsgBox ("Specified panel does not exist !! Your input will be
cleared and replaced with an arbitrary load of 2 KVA.")
Target.Value = 2
End If
End If
End If
End If
‘… more codes
‘** more codes
‘** more codes ( about 5 pages of codes)
End Sub
This attempt failed. I would appreciate it very much any help and tips
on how to make the shared procedure work.
Jim Chee
Houston, TX
|