I'm trying to hide or show connector elbows based on a value. My worksheet links to "Module1", however it gives me the compile error: Argument not optional. I've made it work, working only in the worksheet, but cannot make it work using multiple different modules.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$48" Then
If Target.Value = 1 Then
Call Route1
If Target.Value = 2 Then
Call Route2
End If
End If
End Sub
Module1:
Sub Route1(ByVal Target As Range)
Shapes.Range(Array("Connector: Elbow 137")).Line.Visible = msoTrue
Shapes.Range(Array("Connector: Elbow 142")).Line.Visible = msoFalse
Shapes.Range(Array("Connector: Elbow 143")).Line.Visible = msoTrue
End Sub
Module2:
Sub Route2(ByVal Target As Range)
Shapes.Range(Array("Connector: Elbow 137")).Line.Visible = msoFalse
Shapes.Range(Array("Connector: Elbow 142")).Line.Visible = msoFalse
Shapes.Range(Array("Connector: Elbow 143")).Line.Visible = msoFalse
End Sub
Thanks :-)
You're calling the "Route1/2" method from the worksheet module, where the implicit context is the worksheet itself, but the called methods are in regular modules, where the implicit "worksheet" context is the ActiveSheet (hence #BigBen's comment above).
Might be easier to handle this all in the worksheet module:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$48" Then ShowRoute Target.Value
End Sub
Sub ShowRoute(RouteNum)
Select Case RouteNum
Case 1, 2:
Me.Shapes("Connector: Elbow 137").Line.Visible = IIf(RouteNum = 1, msoTrue, msoFalse)
Me.Shapes("Connector: Elbow 142").Line.Visible = msoFalse
Me.Shapes("Connector: Elbow 143").Line.Visible = IIf(RouteNum = 1, msoTrue, msoFalse)
Case Else:
'?
End Select
End Sub
Related
"I am trying to run Private Sub Worksheet_Change(ByVal Target As Range) for E7:E17 to achive below (For Example)
If E7 = Yes then F7="Reject", G7=H7, I7=2*10,
E7 = No then F7="Pass", G7=H7*5, I7=2,
.
.
If E17 = = Yes the F17="Type", G7=H17, I17=2*10,
E17 = No then F17="Pass", G17=H17*5, I17=2,
I tried like righting separate code for each row, code works for only 7 rows after that error is coming (Procedure is too Long)
Worksheet_Change code:-
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("E7:E17")) Is Nothing Then
Select Case Range("E7:E17")
Case "NO": MacroNoE7
Case "YES": MacroYesE7
End Select
End If
End Sub
Example of VBA Code to run in rows E7:E17:-
Sub MacroYesE7()
Sheets("Data").Range("E162").Copy
Sheets("Data").Range("L7").PasteSpecial xlPasteValidation
Application.CutCopyMode = False
Sheets("Data").Range("L7") = ""
Sheets("Data").Range("M7") = ""
End Sub
Sub MacroNoE7()
Range("L7").Select
With Selection.Validation
.Delete
End With
Sheets("Data").Range("L7") = "NA"
Sheets("Data").Range("M7") = "NA"
End Sub
Error Message:- Procedure is too long
See if this works. Pass Target (the changed cell) to each of the subs.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("E7:E17")) Is Nothing Then
Select Case Target.Value
Case "NO": MacroNo (Target)
Case "YES": MacroYes (Target)
End Select
End If
End Sub
Sub MacroYes(r As Range)
Sheets("Data").Range("E162").Copy
Sheets("Data").Range("L" & r.Row).PasteSpecial xlPasteValidation
Application.CutCopyMode = False
Sheets("Data").Range("L" & r.Row).Resize(, 2).ClearContents
End Sub
Sub MacroNo(r As Range)
Range("L" & r.Row).Validation.Delete
Sheets("Data").Range("L" & r.Row).Resize(, 2).Value = "NA"
End Sub
My goal was to make autocomplete active for dropdowns and I have achieved it for a single worksheet but duplicating the code to other worksheets is not working.
I started by creating a combo Box on the initial worksheet containing the drop downs and then made the following changes-
Changed the name to TempCombo in the Name field
Selected 1-fmMatchEntryComplete in the MatchEntry field;
I then inserted the following code for that worksheet:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Update by Extendoffice: 2017/8/15
Dim xCombox As OLEObject
Dim xStr As String
Dim xWs As Worksheet
Set xWs = Application.ActiveSheet
On Error Resume Next
Set xCombox = xWs.OLEObjects("TempCombo")
With xCombox
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
If Target.Validation.Type = 3 Then
Target.Validation.InCellDropdown = False
Cancel = True
xStr = Target.Validation.Formula1
xStr = Right(xStr, Len(xStr) - 1)
If xStr = "" Then Exit Sub
With xCombox
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 5
.Height = Target.Height + 5
.ListFillRange = xStr
.LinkedCell = Target.Address
End With
xCombox.Activate
Me.TempCombo.DropDown
End If
End Sub
Private Sub TempCombo_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal
`Shift As Integer)`
Select Case KeyCode
Case 9
Application.ActiveCell.Offset(0, 1).Activate
Case 13
Application.ActiveCell.Offset(1, 0).Activate
End Select
End Sub
This implementation works perfectly for that sheet but when i attempt to use the same code on another worksheet on the same file the autocomplete function doesn't work.
I attempted modification of the combobox name on sheet2 to TempCombo2 and changed the following line:
Set xCombox = xWs.OLEObjects("TempCombo")
to
Set xCombox = xWs.OLEObjects("TempCombo2")
The autocomplete function fails to work on sheet 2 even though no error is thrown.
This is a pretty interesting idea, I like it.
I was able to get this to work on multiple sheets with the following modifications:
Removed Cancel = True, this line was throwing an error and Cancel is not an argument in Worksheet_SelectionChange; I don't think this is doing anything.
Copied the code to the second sheet's code module (it has to be in each sheet module that you want it to run on)
updated Set xCombox = xWs.OLEObjects("TempCombo") to Set xCombox = xWs.OLEObjects("TempCombo2")
Me.TempCombo.DropDown updated to Me.TempCombo2.DropDown since that is what I named the combo box on the second sheet
Also, not a change as much as an assumption, it seems it only works with the ActiveX controls, so I assume that's what you are using when you add the new box.
As a follow up I was able to get it to work using the workbook module as long as the combo box is named "TempCombo" on all sheets (you have to add a combobox named "TempCombo" to each sheet). Going this route, you only need the code once, on the workbook module , and it uses the combo box that is local to each sheet.
TO TEST - In a new workbook: add list validation to a range using a range reference, put some values in the list range, add an ActiveX combobox to the sheet and name it "TempCombo", put the following code in the workbook module, then click anywhere in the range that has the list validation enabled.
One other note, make sure you aren't still in design mode on the developer tab!
Option Explicit
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
'Update by Extendoffice: 2017/8/15
Dim xCombox As OLEObject
Dim xStr As String
Dim xWs As Worksheet
Set xWs = Sh
On Error Resume Next
Set xCombox = xWs.OLEObjects("TempCombo")
With xCombox
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
If Target.Validation.Type = 3 Then
Target.Validation.InCellDropdown = False
'Cancel = True
xStr = Target.Validation.Formula1
xStr = Right(xStr, Len(xStr) - 1)
If xStr = "" Then Exit Sub
With xCombox
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 5
.Height = Target.Height + 5
.ListFillRange = xStr
.LinkedCell = Target.Address
End With
xCombox.Activate
Sh.TempCombo.DropDown
End If
End Sub
Private Sub TempCombo_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case 9
Application.ActiveCell.Offset(0, 1).Activate
Case 13
Application.ActiveCell.Offset(1, 0).Activate
End Select
End Sub
I have basic code that allows the values written to this cell to be summed while maintaining the cumulative value. So if I were to type "4" into the cell, and then type "10" into the cell, the result would be "14" (not just the second value entered of "10"). Here is what I have and I must say that it works.
#
Option Explicit
Dim oldvalue As Double
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Address = "$J$5" Then
On Error GoTo fixit
Application.EnableEvents = False
If Target.Value = 0 Then oldvalue = 0
Target.Value = 1 * Target.Value + oldvalue
oldvalue = Target.Value
fixit:
Application.EnableEvents = True
End If
End Sub
#
However, I want to apply this treatment to more than just cell J5. Say for example, I want the same code logic applied to cell R5 as well.
Thur far I have tried using
OR
and I have also tried using
If Not Intersect (Target, Range("J5:R5")) Is Nothing Then
But each of these approaches ties the two cells together (so that what I enter into one gets summed into both - each cell is summing values added to the other). I can't figure it out to save my life, so took to this forum in the hopes of finding someone smarter than me.
Maybe (this is assuming existing logic is correct....not sure why you set old value to 0 if Target = 0 and what value the *1 adds?)
Option Explicit
Dim oldvalueJ As Double
Dim oldValueR As Double
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
On Error GoTo fixit
Application.EnableEvents = False
Select Case Target.Address
Case "$J$5"
If Target = 0 Then oldvalueJ = 0
Target = Target + oldvalueJ
oldvalueJ = Target
Case "$R$5"
If Target = 0 Then oldValueR = 0
Target = Target + oldValueR
oldValueR = Target
End Select
fixit:
Application.EnableEvents = True
End Sub
This is a bit more dynamic by allowing you to add unlimited cells; it also validates user input
Standard Module
Option Explicit 'Generic Module
Public Const WS1_MEM_RNG = "C5,J5,R5" 'Sheet1 memory cells
Public prevWs1Vals As Object
Public Sub SetPreviousWS1Vals()
Dim c As Range
For Each c In Sheet1.Range(WS1_MEM_RNG).Cells
If Len(c.Value2) > 0 Then prevWs1Vals(c.Address) = c.Value2
Next
End Sub
Sheet1 Module
Option Explicit 'Sheet1 Module
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.CountLarge = 1 Then
If Not Intersect(Target, Me.Range(WS1_MEM_RNG)) Is Nothing Then GetPrevious Target
End If
End Sub
Private Sub GetPrevious(ByVal cel As Range)
Dim adr As String: adr = cel.Address
Application.EnableEvents = False
If Not IsError(cel.Value) And IsNumeric(cel.Value2) And Not IsNull(cel.Value) Then
If IsDate(cel.Value) Then
cel.NumberFormat = "General"
cel.Value2 = prevWs1Vals(adr)
Else
If cel.Value2 = 0 Then prevWs1Vals(adr) = 0
cel.Value2 = cel.Value2 + prevWs1Vals(adr)
prevWs1Vals(adr) = cel.Value2
End If
Else
cel.Value2 = prevWs1Vals(adr)
End If
Application.EnableEvents = True
End Sub
ThisWorkbook Module
Option Explicit 'ThisWorkbook Module
Private Sub Workbook_Open()
If prevWs1Vals Is Nothing Then Set prevWs1Vals = CreateObject("Scripting.Dictionary")
SetPreviousWS1Vals
End Sub
It can also enforce positives only
use commas to separate ranges, and add a Worksheet_SelectionChange() event to record the last user selected cell
Option Explicit
Dim oldvalue As String
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Intersect(Target, Range("J5,R5")) Is Nothing Then Exit Sub
If Target.Value = 0 Then Exit Sub
On Error GoTo fixit
Application.EnableEvents = False
Target.Value = Target.Value + oldvalue
fixit:
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.CountLarge = 1 Then oldvalue = Target.Value
End Sub
I want to lock cell B20 and write "1" on it if I choose a certain option ("T") on the dropdown of B18. If I choose any other option, I want to be able to fill it normally without any limitations. Here is the best code I tried:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Set ws = ActiveSheet
If Target.Address = "$B$18" Then
ws.Unprotect
Application.EnableEvents = False
Target.Offset(1).Locked = Target.Value = "T"
If Target.Value = "T" Then
Target.Offset(1).Value = 1
Else
If Target.Offset(1).Value = 1 Then Target.Offset.Value = ""
End If
Application.EnableEvents = True
ws.Protect
End If
End Sub
This code is doing exactly what I want but its performing this on the cell B19 instead of B20.
Can somebody help me please?
There is a bunch of code and text all saying different things in your question, so I based this code on your comment and the text of your question.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$18" Then
ws.Unprotect
Application.EnableEvents = False
Target.Offset(2).Locked = Target.Value = "T"
If Target.Value = "T" Then
Target.Offset(2).Value = 1
Else
If Target.Offset(2).Value = 1 Then Target.Offset.Value = ""
End If
Application.EnableEvents = True
ws.Protect
End If
End Sub
Option Explicit
Public PlotName As String
Public PlotRange As Range
Sub Tester()
Range("TCKWH.V.1").Select
AddPlot ActiveSheet.Range("KWH_G_1")
End Sub
Sub AddPlot(rng As Range)
With ActiveSheet.Shapes.AddChart
PlotName = .Name
.Chart.ChartType = xlLineMarkers
.Chart.SetSourceData Source:=Range(rng.Address())
.Chart.HasTitle = True
.Chart.ChartTitle.Text = Range("KWH.G.1")
.Chart.Axes(xlValue, xlPrimary).HasTitle = True
.Chart.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = Range("KWH.G.1")
End With
Set PlotRange = rng
Application.EnableEvents = False
rng.Select
Application.EnableEvents = True
End Sub
Sub FixPlott(rng As Range)
Dim n As Long
With ActiveSheet.Shapes(PlotName)
For n = .SeriesCollection.Count To 1 Step -1
With .SeriesCollection(n)
If PlotName = "" Then
.Delete
End If
End With
Next n
End With
End Sub
Sub RemovePlot(rng As Range)
If Not PlotRange Is Nothing Then
If Application.Intersect(rng, PlotRange) Is Nothing Then
On Error Resume Next
rng.Parent.Shapes(PlotName).Delete
On Error GoTo 0
End If
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.ScreenUpdating = False
RemovePlot Target
Application.ScreenUpdating = True
End Sub
I need help with Sub FixPlott. I am trying to get it to delete the Legend Entries on the Legend Key. For example if I select Main Campus and South Hall there will be blank legend entries for dunblane and greensburg. Id like the legend just to show selected buildings.
Here you have a corrected version of your sub:
Sub FixPlott(PlotName As String)
Dim n As Long
With ActiveSheet.Shapes(PlotName).Chart
For n = .SeriesCollection.Count To 1 Step -1
With .SeriesCollection(n)
If .Name = "" Then
ActiveSheet.Shapes(PlotName).Chart.Legend.LegendEntries(n).Delete
End If
End With
Next n
End With
End Sub
I am not sure about the exact trigger you want to use. So I have included a simple string trigger; if the given SeriesCollection is called like trigger, the legend will be deleted.