The AddComment syntax works on first selected sheet in workbook, but for the next one gives me this error: Error 1004 "Application-defined or Object-defined error". I do not know why crashes if multiple sheets were selected and works only for the first selected one. Does anyone have some idea?
If selectedSheet.Cells(7, columnIndex).value <> 100 Then
selectedSheet.Cells(7, columnIndex).Interior.ColorIndex = 3
If standardReportFilePath <> "" Then 'not using the Standard Report Evalution algorithm
If VerifyStandardReportFile(selectedSheet.Name, selectedSheet.Cells(1, columnIndex).value, wbk, amplitude, missingCrashes) = True Then
selectedSheet.Cells(1, columnIndex).Interior.ColorIndex = 36 ' color the crash cell with yellow
Set rng = selectedSheet.Cells(1, columnIndex)
If rng.Comment Is Nothing Then
**rng.AddComment "In Standard Report this crash starts to deploy from " & CStr(amplitude) & " amplitude"**
Else
rng.Comment.Text "In Standard Report this crash starts to deploy from " & CStr(amplitude) & " amplitude"
End If
End If
End If
End If
End If
An alternate set of code that shows the problem. (Run this with three blank worksheets in a new workbook.):
Sub test()
Dim ws As Worksheet
Dim Rng As Range
'Running code with a single sheet selected
Worksheets("Sheet1").Select
'Code that shows issue - this will work
Set ws = Worksheets("Sheet2")
Set Rng = ws.Cells(1, 1)
If Rng.Comment Is Nothing Then
Rng.AddComment "xxx"
End If
'Get rid of comment again
Rng.Comment.Delete
'Running code with multiple sheets selected
Worksheets(Array("Sheet1", "Sheet2", "Sheet3")).Select
'Code that shows issue - will crash on the "AddComment"
Set ws = Worksheets("Sheet2")
Set Rng = ws.Cells(1, 1)
If Rng.Comment Is Nothing Then
Rng.AddComment "xxx"
End If
End Sub
I found a workaround, but still don't know why this problem even happens. For some reason error occurs when you have more then one worksheet selected. The solution is... To select one sheet before adding comments with someSheet.Select. At the end of macro you can try to select all previously selected sheets again if needed.
What I do understand - thanks to Yoweks comment - is:
You are looping through all the selected sheets, check something, set comments (giving you the problems, because it does'nt work with more than one selected sheet) and want the previosly selected sheets to be selected afterwards.
You can save the previosly selected sheet in a variable, select one of them, run your code and then select all previosly selected sheets again. PLease try the following code:
Sub Comments()
Dim WsArr As Sheets, WS As Worksheet, ColIdx As Long
ColIdx = 7
Set WsArr = ActiveWorkbook.Windows(1).SelectedSheets
WsArr(1).Select
For Each WS In WsArr
'*** your logic
Set Rng = WS.Cells(1, ColIdx)
If Rng.Comment Is Nothing Then
Rng.AddComment "In Standard Report this crash starts to deploy from " & CStr(amplitude) & " amplitude"
Else
Rng.Comment.Text "Changed T"
End If
Next WS
WsArr.Select
End Sub
From the Excel documentation
You can add notes to individual cells by using comments
You can see in the 'Review' tab within Excel that, when you select multiple sheets, you cannot create a comment. I assume this is to do with Excel's internals determining which cell should have a comment assigned to it.
Here is a function which you can call to assign a comment to a given cell, even if you have multiple sheets selected.
This sub also removes the need to test if a comment already exists, simply pass a new comment to a cell which already has one.
Sub UpdateComment(Rng As Range, Cmnt As String)
Application.ScreenUpdating = False
' Get currently selected sheets
Dim mySheets As Sheets: Set mySheets = ThisWorkbook.Windows(1).SelectedSheets
' Set current selection to just one sheet: this is where error is avoided
ThisWorkbook.Sheets(1).Select
' Set Comment, new if doesn't exist or changed if it does
If Rng.Comment Is Nothing Then
Rng.AddComment Cmnt
Else
Rng.Comment.Text Cmnt
End If
' Tidy up: re-select sheets & enable screen updating
mySheets.Select
Application.ScreenUpdating = True
End Sub
Use it like so in your code:
' ... your previous code
Set rng = selectedSheet.Cells(1, columnIndex)
UpdateComment rng, "In standard report this crash starts to deploy from ..."
To loop over all selected sheets
Dim sh As Worksheet
For Each sh In ThisWorkbook.Windows(1).SelectedSheets
Set rng = sh.Cells(1, columnIndex)
UpdateComment rng, "In standard report this crash starts to deploy from ..."
Next sh
I had the same problem while trying to get a comments function to work so instead of trying to figure it out per scenario, I decided to do a general one; call as needed.
Sub General_Functions_Comments(InCell As Range, TxtComment As String, Optional IsMergedAnalyzed As Boolean)
Dim IsComment As Comment
Dim RangeFixedMerged As Range
If InCell.MergeCells = False Or IsMergedAnalyzed = True Then ' 3. If InCell.MergeCells = False
With InCell
Set IsComment = .Comment
If IsComment Is Nothing Then ' 1. If Iscomment Is Nothing
.AddComment.Text Text:=TxtComment
.Comment.Shape.TextFrame.AutoSize = True
.Comment.Visible = False
Else ' 1. If Iscomment Is Nothing
If InStr(.Comment.Text, TxtComment) Then ' 2. If InStr(.Comment.Text, TxtComment)
Else ' 2. If InStr(.Comment.Text, TxtComment)
.Comment.Text .Comment.Text & Chr(10) & TxtComment
.Comment.Shape.TextFrame.AutoSize = True
.Comment.Visible = False
End If ' 2. If InStr(.Comment.Text, TxtComment)
End If ' 1. If Iscomment Is Nothing
End With
Else ' 3. If InCell.MergeCells = False
Set RangeFixedMerged = InCell.Cells(1, 1)
Call General_Functions_Comments(RangeFixedMerged, TxtComment, True)
Set RangeFixedMerged = Nothing
End If ' 3. If InCell.MergeCells = False
End Sub
In your code
If standardReportFilePath <> "" Then 'not using the Standard Report Evalution algorithm
If VerifyStandardReportFile(selectedSheet.Name, selectedSheet.Cells(1, columnIndex).Value, wbk, amplitude, missingCrashes) = True Then
selectedSheet.Cells(1, columnIndex).Interior.ColorIndex = 36 ' color the crash cell with yellow
Set Rng = selectedSheet.Cells(1, columnIndex)
If Rng.Comment Is Nothing Then
Call General_Functions_Comments(Rng, "In Standard Report this crash starts to deploy from " & CStr(amplitude) & " amplitude", True)
Else: Call General_Functions_Comments(Rng, "In Standard Report this crash starts to deploy from " & CStr(amplitude) & " amplitude", True)
End If
End If
End If
End If
End If
*Aside question, why to set an if, else statement if both will do the same?
I remember generally similar case (I could not do something from code), trying hard to solve it and finally I found that...
Note that if you have multiple sheets selected, "New comment" button on the ribbon is inactive, so you just can't do it from code if you cannot do it manually.
Why? - don't ask me. I see a nice workaround above, which seems to be the only way to achieve what you need.
Related
I have some VBA code that I would like to set the format (forecolour) of all cells in a given workbook that match some criteria (essentially this is to auto-mark use of a particular UDF). If the user has protected sheets in their workbook, they may have (sensibly) protected them in such a way that formatting is still permitted.
How do I check (from the VBA Range object representing the cell) whether a cell on any given worksheet is good to make format edits to?
I am aware the route-one answer to this will be an error handler to try it and handle the cases that fail - but as this has to run on every cell in the UsedRange of every sheet, I want it to be fast. I also realise that this is VBA, so there may not be a faster or more elegant way - but there is a lot of collected wisdom on here, hence my asking!
I think error handling is still the way to go. But as far as I can tell, if formatting fails for one cell in your sheet, it will fail for all other cells, even if those cell are unlocked.
Try the following strategy: The idea is that if formatting fails for any cell, you stop attempting to format the current sheet and move on to the next.
Sub MyProcedure()
Dim sht As Worksheet
Dim cl As Range
For Each sht In ThisWorkbook.Sheets
For Each cl In sht.UsedRange
On Error Resume Next
' Format the cell in a DIFFERENT procedure so that
' if an error occurs the rest of formatting lines are
' are not attempted (this is the key idea)
ApplyFormat cl
If Err.Description = "Application-defined or object-defined error" Then
Err.Clear
Exit For
End If
Next cl
'* Either reset your error handling here if you have more code for each sheet
On Error GoTo 0
' ...more code
Next sht
'* Or eset you error handling here
On Error GoTo 0
' ...more code
End Sub
Sub ApplyFormat(cl As Range)
' apply your formatting here
End Sub
You need to firstly check if the sheet is protected and do what you need if not.
If Protected, you should check only the range you try changing if is locked, has cells locked on is not and do the job only if is unlocked. You cannot check if the cells have a protected format... The next code will show you (I think) what is to be done in such a case:
Sub testSheetProtectedLockedCells()
Dim sh As Worksheet, rng As Range
Set sh = ActiveSheet: Set rng = sh.Range("A2:C4")
'Just for testing: _________________________________________
rng.Locked = Not rng.Locked 'lock - unlock the range...
rng.cells(1, 1).Locked = Not rng.cells(1, 1).Locked ' lock-unlock one cell of the range
'___________________________________________________________
If Not sh.ProtectionMode Then
DoIt rng
Else
If rng.Locked = False Then
DoIt rng
ElseIf IsNull(rng.Locked) Then
MsgBox "Cell(s) of the range """ & rng.address & """ are locked." & vbCrLf & _
"Please, unlock all the range and run the code again!", vbInformation, _
"Locked cells in the range to be processed..."
Else
MsgBox "The range """ & rng.address & """ is locked." & vbCrLf & _
"Please, unlock it and run the code again!", vbInformation, _
"Locked range to be processed..."
End If
End If
End Sub
Sub DoIt(rng As Range) 'do here the job you need...
Debug.Print rng.address, rng.Locked
End Sub
I am currently trying to write a piece of code where someone is able to use a checkbox to choose which worksheets they would like to keep and what they would like removed. Here is what that looks like:
(currently debating if I should turn this into a userform but i would still be stuck at this point).
What I would like to do is if the checkbox is unchecked (false) on the worksheet called "Setup", delete the worksheet and move onto the next if statement. From the code below, I am prompt with the run-time error '1004': Unable to get the OLEObjects property of the worksheet class. I have checked and the Checkbox name is the same as what I have in my code.
Sub DeleteSheetCB()
If ThisWorkbook.Worksheets("Setup").OLEObjects("CheckBox1") = False Then
ThisWorkbook.Worksheets("Program Information").Delete
End If
If ThisWorkbook.Worksheets("Setup").OLEObjects("CheckBox2") = False Then
ThisWorkbook.Worksheets("Spend and Trx Data").Delete
End If
If ThisWorkbook.Worksheets("Setup").OLEObjects("CheckBox3") = False Then
ThisWorkbook.Worksheets("Requirements").Delete
End If
If ThisWorkbook.Worksheets("Setup").OLEObjects("CheckBox4") = False Then
ThisWorkbook.Worksheets("TMC Overview").Delete
End If
End Sub
Thank you in advance
EDIT:
I was able to get this piece of code to delete sheets but if possible, would someone be able to sense check this for me please?
Sub DeleteSheetCB()
If ThisWorkbook.Worksheets("Setup").Shapes("Check Box 1").ControlFormat.Value <> 1 Then
ThisWorkbook.Worksheets("Program Information").Delete
Else: End If
If ThisWorkbook.Worksheets("Setup").Shapes("Check Box 2").ControlFormat.Value <> 1 Then
ThisWorkbook.Worksheets("Spend and Trx Data").Delete
Else: End If
If ThisWorkbook.Worksheets("Setup").Shapes("Check Box 3").ControlFormat.Value <> 1 Then
ThisWorkbook.Worksheets("Requirements").Delete
Else: End If
If ThisWorkbook.Worksheets("Setup").Shapes("Check Box 4").ControlFormat.Value <> 1 Then
ThisWorkbook.Worksheets("TMC Overview").Delete
Else: End If
End Sub
The main thing I'd take from your second code is:
It will give you a warning before it deletes each sheet
You'll get a subscript out of range error if the sheet has already been deleted.
You have to update your code if you add a new tick box.
The code below assumes the caption of the checkbox is exactly the same as the name of the sheet to be deleted.
Sub DeleteSheetCB()
Dim chkBox As CheckBox
Dim sMissing As String
With ThisWorkbook.Worksheets("Setup")
For Each chkBox In .CheckBoxes 'Look at all checkboxes in Setup sheet.
If chkBox.Value = 1 Then 'If it's ticked.
If WorksheetExists(chkBox.Caption) Then 'Check worksheet exists.
Application.DisplayAlerts = False 'Turn off warnings about deleting a sheet.
ThisWorkbook.Worksheets(chkBox.Caption).Delete
Application.DisplayAlerts = True 'Turn on warnings about deleting a sheet.
Else
sMissing = sMissing & "- " & chkBox.Caption & vbCr
End If
End If
Next chkBox
End With
If sMissing <> "" Then
MsgBox "These sheet(s) could not be deleted as they were already missing: " & vbCr & vbCr & sMissing
End If
End Sub
Public Function WorksheetExists(SheetName As String) As Boolean
Dim wrkSht As Worksheet
On Error Resume Next
Set wrkSht = ThisWorkbook.Worksheets(SheetName) 'Try and set a reference to the sheet.
WorksheetExists = (Err.Number = 0) 'Was an error thrown?
On Error GoTo 0
End Function
Might also be worth mentioning that you can rename your checkboxes:
Select a check box so the Shape Format ribbon becomes visible.
Click Selection Pane under the Arrange section.
A sidebar will appear showing the shapes on the sheet. You can rename or change their visibility here.
chkRemoveProgramInfo makes more sense than Check Box 1.
I have this code but it only work for my first row.
It is suppose to look if the checkbox on B, C or D is checked, and if so, a date + username will automaticaly fill in F and G.
here is a picture of my table:
This is what my code looks like:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Range("B2") Or Range("C2") Or Range("D2") = True Then
Range("G2").Value = Environ("Username")
Range("F2").Value = Date
Else
Range("F2:G2").ClearContents
End If
End Sub
Enter this code in a regular module, select all your checkboxes and right-click >> assign macro then choose ReviewRows.
This will run the check whenever a checkbox is clicked - a bit of overhead since all rows will be checked, but should not be a big deal.
Sub ReviewRows()
Dim n As Long
For n = 1 To 100 'for example
With Sheet1.Rows(n)
If Application.CountIf(.Cells(2).Resize(1, 3), "TRUE") > 0 Then
If Len(.Cells(6).Value) = 0 Then 'only enter if currently empty?
.Cells(6) = Date
.Cells(7) = Environ("Username")
End If
Else
.Cells(6).Resize(1, 2).ClearContents
End If
End With
Next n
End Sub
If you want to be more precise then Application.Caller will give you the name of the checkbox which was clicked, and you can use that to find the appropriate row to check via the linkedCell.
Sub ReviewRows()
Dim n As Long, shp As CheckBox, c As Range, ws As Worksheet
Set ws = ActiveSheet
On Error Resume Next 'ignore error in case calling object is not a checkbox
Set shp = ActiveSheet.CheckBoxes(Application.Caller) 'get the clicked checkbox
On Error GoTo 0 'stop ignoring errors
If Not shp Is Nothing Then 'got a checkbox ?
If shp.LinkedCell <> "" Then 'does it have a linked cell ?
With ws.Range(shp.LinkedCell).EntireRow
If Application.CountIf(.Cells(2).Resize(1, 3), "TRUE") > 0 Then
If Len(.Cells(6).Value) = 0 Then 'only enter if currently empty?
.Cells(6) = Date
.Cells(7) = Environ("Username")
End If
Else
.Cells(6).Resize(1, 2).ClearContents
End If
End With
End If 'has linked cell
End If 'was a checkbox
End Sub
However this appraoch is sensitive to the exact positioning of your checkbox
You have a long way to go!
Unfortunately, If Range("B2") Or Range("C2") Or Range("D2") = True Then is beyond repair. In fact, your entire concept is.
Start with the concept: Technically speaking, checkboxes aren't on the worksheet. They are on a layer that is superimposed over the worksheet. They don't cause a worksheet event, nor are they responding to worksheet events. The good thing is that they have their own.
If Range("B2") Or Range("C2") Or Range("D2") = True Then conflates Range with Range.Value. One is an object (the cell), the other one of the object's properties. So, to insert sense into your syntax it would have to read, like, If Range("B2").Value = True Or Range("C2").Value = True Or Range("D2").Value = True Then. However this won't work because the trigger is wrong. The Worksheet_Change event won't fire when when a checkbox changes a cell's value, and the SelectionChange event is far too common to let it run indiscriminately in the hope of sometimes being right (like the broken clock that shows the correct time twice a day).
The answer, therefore is to capture the checkbox's click event.
Private Sub CheckBox1_Click()
If CheckBox1.Value = vbTrue Then
MsgBox "Clicked"
End If
End Sub
Whatever you want to do when the checkbox is checked must be done where it now shows a MsgBox. You can also take action when it is being unchecked.
This works perfectly, but I only want it to reference a single sheet instead of every sheet in the workbook
Private Sub Worksheet_Change()
Dim LastRow As Long, c As Range
Application.EnableEvents = False
LastRow = Cells(Cells.Rows.Count, "AA120").End(xlUp).Row
On Error Resume Next
For Each c In Range("AA5:AA120" & LastRow)
If c.Value = "0" Then
c.EntireRow.Hidden = True
ElseIf c.Value > "0" Then
c.Activate
c.EntireRow.Hidden = False
End If
Next
On Error GoTo 0
Application.EnableEvents = True
End Sub
As i can see you only need to insert this code in one sheet which ever you want. Rightclick on sheet name(tab) and select "view code", then paste this code. BUT! If this runs on every sheet, then you also need to delete code from "This Workbook" --> (Alt+F11) and select "This workbook", then erase this code from there.
You have to use
Private Sub Worksheet_Change(ByVal Target As Range)
instead.
According to the great Chip Pearson, "The events and their procedure declarations are fixed. You must not alter the name or parameter list of an event procedure." (I do not have a system with Office to test it).
You would insert your Sub in a sheet module, and it will work only on that sheet.
Why would an input box stop accepting a selection by mouse after a call to a sub with screenupdating variable changes?
I have a large workbook in excel that calculates a budget from different components on different sheets. I'm using named ranges in all of my formulas, and as I build the workbook I often need to move things around on the sheet, and thus edit the references to my named ranges so I made a macro to run through my named ranges and let me click to update their references.
I've included three subs from my workbook code; sheet 1 just has some values in the named range cells, a formula ( = CNGFixedCost1 + CNGFixedCost2 + CNGFixedCost3), and an activex check box. When I run RangeNameManager() the inputbox stops accepting mouse selections, due to the screenupdating variable in the Worksheet_Calculate() sub, . I figured out how to resolve the problem while writing this up (remove the screenupdating changes), but I'm still curious as to why this happens.
Option Explicit
'Name Ranges in workbook
Public Sub Workbook_Open()
Worksheets("Sheet1").Range("D3").Name = "CNGFixedCost1"
Worksheets("Sheet1").Range("D4").Name = "CNGFixedCost2"
Worksheets("Sheet1").Range("D5").Name = "CNGFixedCost3"
End Sub
'Update named ranges
Sub RangeNameManager()
Dim nm As Name
Dim nms As String
Dim xTitleID As String
Dim InputRng As Range
Dim asnms As String
On Error Resume Next
asnms = CStr(ActiveSheet.Name)
For Each nm In ActiveWorkbook.Names
nms = CStr(nm.Name)
If nm.RefersTo Like "*" & asnms & "*" Then
Set InputRng = ActiveSheet.Range("A1")
Set InputRng = Application.InputBox("The current range for" & nms & " is " & CStr(nm.RefersTo) & ". Select the new range.", InputRng.Address, Type:=8)
nm.RefersTo = InputRng
End If
Next
On Error GoTo 0
End Sub
' Update check box automatically
Private Sub Worksheet_Calculate()
Application.ScreenUpdating = False '***Removed to resolve problem.***
Dim errwksht As String
errwksht = ActiveSheet.Name
On Error GoTo ErrorHandler
If Worksheets("Sheet1").Range("CNGFixedCost1").Value > 0 Then
Worksheets("Sheet1").CheckBox1.Value = False
Else
Worksheets("Sheet1").CheckBox1.Value = True
End If
ErrorHandler:
Exit Sub
Application.ScreenUpdating = True '***Removed to resolve problem.***
End Sub
ScreenUpdating is a property of the Application object. If you turn it to false, then the application cuts off connection with the user (it won't take input, and it won't update the display).
It's very useful if you want to make something run faster, however it shouldn't be used during times when you need user interaction.
You're exiting the sub before turning screen updating back on, leaving the application in an unstable state.
' Update check box automatically
Private Sub Worksheet_Calculate()
Application.ScreenUpdating = False '***Removed to resolve problem.***
'...
ErrorHandler:
Exit Sub 'exits here
Application.ScreenUpdating = True ' so this NEVER executes
End Sub
This is easily fixed by resuming at your error handler, which would be better named CleanExit:. Here's how I would write it.
Private Sub Worksheet_Calculate()
On Error GoTo ErrorHandler
Application.ScreenUpdating = False '***Removed to resolve problem.***
'...
CleanExit:
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
' Actually do some error handling
Resume CleanExit
End Sub