Option Explicit
Public Sub PlotFullOne()
PlotTemplate "FullOne"
End Sub
Public Sub PlotFullTwo()
PlotTemplate "FullTwo"
End Sub
Public Sub PlotSmallOne()
PlotTemplate "SmallOne"
End Sub
Public Sub PlotSmallTwo()
PlotTemplate "SmallTwo"
End Sub
Public Sub PlotTemplate(ByVal argTemplateName As String)
Const PH As String = "@#$@"
Const ERROR_MSG As String = "Template with name [" & PH & "] is not present or is not recognized."
Const PLOT_ROWCOUNT As Long = 5
Const PLOT_ROWHEIGHT As Long = 9
Const TEMPL_FULLWIDTH As Long = 27
Const TEMPL_SMALLWIDTH As Long = 9
Const TEMPLATE_OFFSET As Long = 3 ' = column D
Const UNDO_OFFSET As Long = 33 ' = column AH
Dim wsSource As Worksheet, wsDest As Worksheet
Dim arrRows() As Variant
Dim d As Range, r As Range, c As Range
Dim n As Long, i As Long
Set wsDest = ThisWorkbook.Worksheets("Layout")
' only allow plotting if sheet for which this procedure is intended is on screen
' otherwise the provided Accept / Undo dialog makes no sense
If ActiveSheet.Name = wsDest.Name Then
Set d = ActiveCell
If Not argTemplateName = vbNullString Then
Set wsSource = ThisWorkbook.Worksheets("Templates")
With wsSource
' range with template names
Set r = .Range("A4:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
End With
' look for given template
Set c = r.Find(argTemplateName, , , xlWhole)
If Not c Is Nothing Then
If Left(argTemplateName, 1) = "F" Then
' set amount of culumns
n = TEMPL_FULLWIDTH
ElseIf Left(argTemplateName, 1) = "S" Then
' set amount of culumns
n = TEMPL_SMALLWIDTH
Else
' unknown prefix = unknown dimension > inform user and quit
MsgBox Replace(ERROR_MSG, PH, argTemplateName), vbExclamation, "Plot template"
Exit Sub
End If
' from this point on, interruptions caused by Excel events are unwanted
' our dropdowns don't have to be monitored for a while so any (custom) event handler can be disabled safely
Application.EnableEvents = False
' store content of destination area, providing an undo possibility
With d.Resize(PLOT_ROWCOUNT, n)
.Copy Destination:=c.Offset(0, UNDO_OFFSET)
' store height of each row involved
ReDim arrRows(PLOT_ROWCOUNT)
For i = 1 To PLOT_ROWCOUNT
arrRows(i) = .Cells(i, 1).EntireRow.Height
Next i
End With
' plot template in Layout sheet
c.Offset(0, TEMPLATE_OFFSET).Resize(PLOT_ROWCOUNT, n).Copy Destination:=d
' adjust row height
d.Resize(PLOT_ROWCOUNT, n).Rows.RowHeight = PLOT_ROWHEIGHT
With c.Offset(0, UNDO_OFFSET).Resize(PLOT_ROWCOUNT, n)
If vbNo = MsgBox("Plotted as intended?", vbQuestion + vbYesNo, "Plot template") Then
' perform an Undo
.Copy Destination:=d
' restore row heights
With d.Resize(PLOT_ROWCOUNT, n)
For i = 1 To PLOT_ROWCOUNT
.Cells(i, 1).EntireRow.RowHeight = arrRows(i)
Next i
End With
End If
' clear undo storage
.ClearContents
.ClearFormats
End With
' enable all event handlers (and monitor our dropdowns again)
Application.EnableEvents = True
Else
' unknown Template Name > inform user and quit
MsgBox Replace(ERROR_MSG, PH, argTemplateName), vbExclamation, "Plot template"
End If
Else
' given Template Name appears to be an empty string ("") > inform user and quit
MsgBox Replace(ERROR_MSG, PH, argTemplateName), vbExclamation, "Plot template"
End If
Else
' wrong worksheet on screen > do nothing
End If
End Sub
Public Sub RespondOnLayoutChange(ByVal Target As Range)
' these constants hold Named Ranges > used as lists within the validation dropdowns
Const FULL_MARKERS As String = "DD_MarkersF"
Const SMALL_MARKERS As String = "DD_MarkersS"
Const FULL_CODES As String = "DD_CodesF"
Const SMALL_CODES As String = "DD_CodesS"
Const EXT_CODES_C As String = "DD_CodesExtC"
Const EXT_CODES_S As String = "DD_CodesExtS"
Dim rng As Range, arr As Variant
Dim dvt As XlDVType, dvf As String
Dim ErrNr As Long, i As Long, clr As Long
' ignore change events from multiple cells at once
If Not Target.CountLarge > 1 Then
' is the data input in the changed cell limited by data validation?
On Error Resume Next
dvt = Target.Validation.Type
ErrNr = Err.Number
On Error GoTo 0
If ErrNr = 0 Then
' validation detected, proceed
If dvt = xlValidateList Then
' we are about to make changes to a worksheet while this code is invoked when that particular worksheet changes
' we therefore need to disable any event handler to prevent endless recursive behaviour
Application.EnableEvents = False
' obtain involved list
dvf = Target.Validation.Formula1
' check whether a specific plotted element is involved
If StrComp(dvf, "=" & FULL_CODES, vbTextCompare) = 0 Then
Set rng = Application.Union(Target.Offset(-1, 1), Target.Offset(1, 1))
MarkersDropDown Target.Value, rng, FULL_CODES, FULL_MARKERS
Target.Offset(-1, 0).Resize(3, 27).Interior.Color = GetColor(Target, FULL_CODES)
ElseIf StrComp(dvf, "=" & SMALL_CODES, vbTextCompare) = 0 Then
Set rng = Application.Union(Target.Offset(-1, 0), Target.Offset(1, 0))
MarkersDropDown Target.Value, rng, SMALL_CODES, SMALL_MARKERS
Target.Offset(-1, 0).Resize(3, 9).Interior.Color = GetColor(Target, SMALL_CODES)
ElseIf StrComp(dvf, "=" & FULL_MARKERS, vbTextCompare) = 0 Then
arr = Array(2, 4, 6, 9, 11, 13, 15, 18, 20, 22, 24)
CombineNotContiguousCellsOnSameRow(Target, arr).Value = Target.Value
ElseIf StrComp(dvf, "=" & SMALL_MARKERS, vbTextCompare) = 0 Then
arr = Array(2, 4, 6, 8)
CombineNotContiguousCellsOnSameRow(Target, arr).Value = Target.Value
ElseIf StrComp(dvf, "=" & EXT_CODES_C, vbTextCompare) = 0 Then
i = Application.Evaluate("=MATCH(""" & Target.Value & """," & EXT_CODES_C & ", 0)")
Target.Interior.Color = Range(EXT_CODES_C).Cells(i, 1).Offset(0, 1).Interior.Color
ElseIf StrComp(dvf, "=" & EXT_CODES_S, vbTextCompare) = 0 Then
i = Application.Evaluate("=MATCH(""" & Target.Value & """," & EXT_CODES_S & ", 0)")
Target.Interior.Color = Range(EXT_CODES_S).Cells(i, 1).Offset(0, 1).Interior.Color
Else
' no plotted element involved > do nothing
End If
' we are done, enable all (custom) event handlers
Application.EnableEvents = True
Else
' data validation detected, but of the wrong type > do nothing
End If
Else
' no data validation detected > do nothing
End If
Else
' multiple cells have been changed at the same time > do nothing
End If
End Sub
Private Function CombineNotContiguousCellsOnSameRow(ByVal Target As Range, ByVal OffsetsArray As Variant) As Range
Dim r As Range, n As Variant
For Each n In OffsetsArray
If r Is Nothing Then
Set r = Target.Offset(0, n)
Else
Set r = Application.Union(r, Target.Offset(0, n))
End If
Next n
Set CombineNotContiguousCellsOnSameRow = r
End Function
Private Sub MarkersDropDown(ByVal argCondition As String, ByVal argDropDownRange As Range, ByVal argCODES As String, argMARKERS As String)
If argCondition = Range(argCODES).Cells(1, 1).Value Then
SetValidationAllowList argDropDownRange, argMARKERS
Else
argDropDownRange.Validation.Delete
End If
End Sub
Private Function GetColor(ByVal Target As Range, ByVal argCODES As String) As Long
Dim i As Long
i = Application.Evaluate("=MATCH(""" & Target.Value & """," & argCODES & ", 0)")
GetColor = Range(argCODES).Cells(i, 1).Offset(0, 1).Interior.Color
End Function
Private Sub SetValidationAllowList(ByVal argRng As Range, ByVal argNameOfList As String)
Dim nm As Name
If Not argRng Is Nothing Then
With argRng.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=" & argNameOfList
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End If
End Sub
drive.google.com
