Hye there.
I would like to ask for any ideas from anyone here.
I have a lot of checkboxes in a worksheet which I link with a chart in the same worksheet. I would like to make a function which run the same code for each of the checkboxes ( I have 24 check boxes overall) when it is click. If you have any idea or suggestion, do tell me.
Here is the idea of mine for the flow of the code. I just have the same flow of code.
Private Sub CheckBox1_Click()
On Error Resume Next
Sheets("REPORT").Activate
ActiveSheets.ChartObjects("STOCK MOVEMENT GRAPH").Activate
On Error GoTo 0
If CheckBox1.Value = False Then
ActiveChart.SeriesCollection(1).Delete
Else
ActiveChart.SeriesCollection.Add Source:=Sheets("REPORT").Range("B4:AB4")
End If
End Sub
Private Sub CheckBox2_Click()
On Error Resume Next
Sheets("REPORT").Activate
Worksheets("REPORT").ChartObjects("STOCK MOVEMENT GRAPH").Activate
On Error GoTo 0
If CheckBox2.Value = False Then
ActiveChart.SeriesCollection(2).Delete
Else
ActiveChart.SeriesCollection.Add Source:=Sheets("REPORT").Range("B5:AB5"), PlotBy:=xlRows
End If
End Sub
Thanks in advance. Regards.
You can pull out the common code into a standalone Sub:
Sub UpdateChart(rowNum As Long, AddingIt As Boolean)
Dim cht As Chart, s As Series, rng As Range, f, i
Set cht = Sheets("REPORT").ChartObjects("STOCK MOVEMENT GRAPH").Chart
'what's the data range?
Set rng = Sheets("REPORT").Range("B3").Offset(rowNum, 0).Resize(1, 2)
If AddingIt Then
'note: not checking if already added....
cht.SeriesCollection.Add Source:=rng
Else
For i = cht.SeriesCollection.Count To 1 Step -1
Set s = cht.SeriesCollection(i)
f = s.Formula
If InStr(f, rng.Address()) > 0 Then s.Delete
Next i
End If
End Sub
Then your checkbox code reduces to this:
Private Sub CheckBox1_Click()
UpdateChart 1, CheckBox1.Value
End Sub
Private Sub CheckBox2_Click()
UpdateChart 2, CheckBox2.Value
End Sub
'etc....
Related
I have a userform. The idea is to check if there are any 'True' values in column(15) in 'Admin' sheet. If there is at least a single 'True' value, then the userform will remain open and continue its operation.
However, if there is not a single 'True' found, then the userform will display a message and close the userform automatically.
Private Sub Userform_initialize()
Dim LR As Long
LR = Sheets("Project_Name").Cells(Rows.Count, "B").End(xlUp).Row
With Worksheets("Admin")
For i = 7 To LR
If .Cells(i, 15) = "True" Then
Exit For
Else
MsgBox ("No values found")
Exit For
Unload Me
End If
Next i
End With
''' more code'''
End Sub
Everything on my userform works as expected, except for the fact I am unable to make it close itself automatically. I.e. Unload Me is not working.
Any advice?
You should check your criteria before you even display the UserForm. You can add this as a condition wherever you are calling the UserForm. No need to open the form just to immediately close it when you can check before-hand.
On the first instance of True, the UserForm will open, and exit the sub. If the loop completes (finds no True values), the sub will proceed to your MsgBox
Sub OpenForm
With Worksheets("Admin")
For i = 7 To LR
If Cells(i,15) = "True" then
Userform.Show
Exit Sub
End If
Next i
End With
MsgBox "No Values Found"
End Sub
Please look at your code; you have put Unload Me is after Exit For
'Here is something for you to ponder on .........
'Public enum type to add a set of particular vbKeys to the standard key set
Public Enum typePressKeys
vbNoKey = 0
vbExitTrigger = -1
vbAnswerKey = 100
vbLaunchKey = 102
vbPrevious = 104
vbNext = 106
vbSpecialAccessKey = 108
End Enum
Public Sub doSomethingWithMyUserform()
Dim stopLoop As Boolean, testVal As Boolean, rngX As Range, LR As Long
LR = ThisWorkbook.Sheets("Project_Name").Cells(Rows.Count, "B").End(xlUp).Row
Set rngX = ThisWorkbook.Worksheets("Admin")
testVal = False
With rngX 'Your sub can do the check here
For i = 7 To LR
If .Cells(i, 15) = "True" Then
testVal = True
Exit For
End If
Next i
End With
If testVal Then
Load UserForm1
With UserForm1
.Caption = "Something"
.Tag = vbNoKey
.button_OK.SetFocus 'Assuming you have a OK button on Userform1
End With
UserForm1.Show
stopLoop = False
Do
If UserForm1.Tag = vbCancel Then
'Do something perhaps
Unload UserForm1
stopLoop = True
ElseIf UserForm1.Tag = vbOK Then
'Do something specific
Unload UserForm1
stopLoop = True
Else
stopLoop = False
End If
Loop Until stopLoop = True
else
MsgBox "No values found"
End If
'Here you can close the way you want
Set rngX = Nothing
End Sub
enter code here
Using the following code to auto upper two columns,
Private Sub Worksheet_Change(ByVal Target As Range)
If Not (Application.Intersect(Target, Range("C2:C5000", "P3:P5000")) _
Is Nothing) Then
With Target
Application.EnableEvents = False
.Value = UCase(.Value)
Application.EnableEvents = True
End With
End If
End Sub
Works perfectly, the problem is, if a user selects multiple cells, and hits delete, it errors, then the user hits End and the function no longer works. protected. Run-time error 13, type mismatch.
Doesn't matter if the cell is empty or not, still get the error.
Thanks in advance.
The answer of #ScottHoltzman solves the issue of the current problem, where an error is raised when you apply UCASE to an Array. When the Target range has more than one cell its .Value is an array, and UCase does not accept an array parameter.
Your routine will exit this line (.Value = UCase(.Value)) and will miss the next line that resets Application.EnableEvents = True. After that, you end up working with events disabled, so all your event handling routines will stop working, not only this one (in case you had other such routines).
To avoid these situations the good approach is to implement proper error handling in event handlers, following this structure
Sub my_Handler()
On Error Goto Cleanup
Application.EnableEvents = False: Application.ScreenUpdating = False ' etc..
''''''''''''''''''''''''''''''''''
'
' normal code of the routine here
'
''''''''''''''''''''''''''''''''''
Cleanup:
if Err.Number <> 0 Then MsgBox Err.Description
Application.EnableEvents = True, Application.ScreenUpdating = True ' etc..
End Sub
To apply it to your routine:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Cleanup
Application.EnableEvents = False: Application.ScreenUpdating = False ' etc..
If Not (Application.Intersect(Target, Range("C2:P5000")) Is Nothing) Then
Target.value = UCase(Target.value)
End If
Cleanup:
If Err.Number <> 0 Then msgBox Err.Description
Application.EnableEvents = True: Application.ScreenUpdating = True ' etc..
End Sub
Importantly, don't use this structure automatically for all you routines, only Event handlers or eventually macros ythat you would invoke from the GUI. Other routines are usually called from these handlers or macros, so you can write them normally.
I tried putting this in a comment to the answer, but was too long, so sorry..
#a-s-h #a.s.h
This one worked the best, with a slight modification. Thanks!
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Cleanup
Application.EnableEvents = False: Application.ScreenUpdating = False ' etc..
If Not (Application.Intersect(Target, Range("C2:C5000", "P3:P5000")) Is Nothing) Then
Target.Value = UCase(Target.Value)
End If
Cleanup:
If Err.Number <> 0 Then GoTo EndLine
EndLine:
Application.EnableEvents = True: Application.ScreenUpdating = True ' etc..
End Sub
Performs uppercase, and deletes multiples at once without any errors, or MsgBox's.
If they are selecting multiple cells then my thinking is that you would want to use SelectionChange macro instead, like this
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
If ((Target.Address = Target.EntireRow.Address Or _
Target.Address = Target.EntireColumn.Address)) Then Exit Sub
Application.EnableEvents = False
If Not (Application.Intersect(Target, Range("C2:C5000", "P3:P5000")) _
Is Nothing) Then
On Error GoTo endItAll
For Each aCell In Target.Cells
Range(aCell.Address) = UCase(Range(aCell.Address))
Next aCell
End If
endItAll:
Application.EnableEvents = True
SecondsElapsed = Round(Timer - StartTime, 2)
Debug.Print SecondsElapsed
End Sub
Or you could change it back to the worksheet_Change macro like below and it will not error if the user selects multiple cells or deletes cells without causing an error. The error handler is there - Like in A.S.H. 's solution, but I haven't yet seen it needed in my testing.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not (Application.Intersect(Target, Range("C1:C5000", "D1:D5000")) _
Is Nothing) Then
On Error GoTo endItAll
For Each aCell In Target.Cells
Range(aCell.Address) = UCase(Range(aCell.Address))
Next aCell
End If
endItAll:
Application.EnableEvents = True
End Sub
Account for multiple cells this way:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not (Application.Intersect(Target, Range("C2:C5000", "P3:P5000")) _
Is Nothing) Then
Dim rCell as Range
Application.EnableEvents = False
For each rCell in Target
rCell.Value = UCase(rCell.Value)
Next
Application.EnableEvents = True
End If
End Sub
When I activate a sheet I want excel to do the following process:
Is cell "A1 and cell "Z1" in the range of my screen?
Yes:
Do nothing
No:
Range("A1:Z1").Select
ActiveWindow.Zoom = True
I want this because my file has to open on different screens/screen resolutions and everything has to be visible for everyone.
I hope somebody can help me.
Couldn't you just check if the range already fits and if it doesn't call the zoom method?
Option Explicit
Public Sub RunMe()
FitColumns "A:Z"
End Sub
Private Sub FitColumns(addr As String)
Dim oldSel As Range
Dim colRange As Range
Set oldSel = Selection
Set colRange = Range(addr).Resize(1)
If Intersect(colRange, ActiveWindow.VisibleRange) Is Nothing Then
colRange.Select
ActiveWindow.Zoom = True
oldSel.Select
End If
End Sub
From the link i posted in the comment, i have come up with this code
Sub temp()
Dim zoomRatio As Integer
zoomRatio = 100
Do While (Not (CellIsInVisibleRange(ActiveSheet.Range("Z1"))))
zoomRatio = zoomRatio - 1
ActiveWindow.Zoom = zoomRatio
Loop
End Sub
Function CellIsInVisibleRange(cell As Range)
CellIsInVisibleRange = Not Intersect(ActiveWindow.VisibleRange, cell) Is Nothing
End Function
Update:
Revised the subroutine to Zoom in if more than column Z is visible and Zoom out if less than Col Z is visible
Sub temp()
Dim zoomRatio As Integer
zoomRatio = ActiveWindow.Zoom
Do While (Not (CellIsInVisibleRange(ActiveSheet.Range("Z1"))))
zoomRatio = zoomRatio - 2
ActiveWindow.Zoom = zoomRatio
Loop
Do While (CellIsInVisibleRange(ActiveSheet.Range("AA1")))
zoomRatio = zoomRatio + 2
ActiveWindow.Zoom = zoomRatio
Loop
End Sub
I fixed it. Thank you!
Private Sub Worksheet_Activate()
If CellIsInVisibleRange(ActiveSheet.Range("Z2")) Then
'Nothing
Else
Range("A2:Z2").Select
ActiveWindow.Zoom = True
Range("D3").Select
End If
End Sub
Function CellIsInVisibleRange(cell As Range)
CellIsInVisibleRange = Not Intersect(ActiveWindow.VisibleRange, cell) Is Nothing
End Function
Hi I'm pretty new at the vba so please don't shoot my code :-).
I have a set of repaeting code's. I woukld like to simplify this code by using the code name with an increasing number. I can't get it to run. Can someone help me a bit on the road to get this going.
Below what I'm trying.
The second block is a part of the code now (it's 40 blocks of the same code only increasing the number)
Sub sheet41()
Dim i As Integer
Dim chkname As Integer
chkname = "SheetCheckBox" & i
i = 1
Do
i = i + 1
If chkname.Visible = False Then Exit Sub
If chkname.value = True Then
Sheets("Item_" & i).Select
Call Finalize
End If
Loop Until i = ThisWorkbook.Worksheets.Count
End Sub
This is the old code:
Sub Sheet1()
If SheetCheckBox1.Visible = False Then Exit Sub
If SheetCheckBox1.value = True Then
Sheets("Item_1").Select
Call Finalize
End If
End Sub
Sub Sheet2()
If SheetCheckBox2.Visible = False Then Exit Sub
If SheetCheckBox2.value = True Then
Sheets("Item_2").Select
Call Finalize
End If
End Sub
Sub Sheet3()
If SheetCheckBox3.Visible = False Then Exit Sub
If SheetCheckBox3.value = True Then
Sheets("Item_3").Select
Call Finalize
End If
End Sub
As you can see this should be possible to clean I asume.
This should do it. If finalize isn't called on a worksheet then the reason why is printed to the Immediate Window.
Sub ProcessWorkSheets()
Dim check As MSForms.CHECKBOX
Dim i As Integer
For i = 1 To Worksheets.Count
On Error Resume Next
Set check = Worksheets(i).OLEObjects("SheetCheckBox" & i).Object
On Error GoTo 0
If check Is Nothing Then
Debug.Print Worksheets(i).Name; " - Checkbox not found"
Else
If check.Visible And check.Value Then
Worksheets(i).Select
Call Finalize
Else
Debug.Print Worksheets(i).Name; " - Checkbox", "Visible", check.Visible, "Value:", check.Value
End If
End If
Set check = Nothing
Next
End Sub
If the checkboxes on the Sheet are ActiveX Controls, you can use this to access the checkboxes:
Sheets("sheet1").OLEObjects("chkTest").Object
if you want to change the value of a checkbox, use it like this:
Sheets("sheet1").OLEObjects("chkTest").Object.Value = True
now replace "sheet1" with your actual sheet name and change the "chkTest" to your string chkname
So your complete code should be like this:
Dim i As Integer
Dim sheetname As String
Dim chkname As String
sheetname = "YOUR SHEETNAME HERE"
For i = 1 To ThisWorkbook.Worksheets.Count Step 1
chkname = "SheetCheckBox" & i
If Sheets(sheetname).OLEObjects(chkname).Object.Visible = False Then Exit Sub
If Sheets(sheetname).OLEObjects(chkname).Object.Value = True Then
Sheets("Item_" & i).Select
Call Finalize
End If
Next i
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.