I am using a VBA code, that highlights the border color of the active cell as the cell selector moves.
The code is
Private mOutline As Shape
Private Const SelectedShapeName As String = "Selection Box"
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Dim SelectedShape As Shape
Dim SelectedArea As Range
On Error Resume Next
For Each SelectedShape In Sh.Shapes
If SelectedShape.Name = SelectedShapeName Then
SelectedShape.Delete
End If
Next SelectedShape
For Each SelectedArea In Selection.Areas
Set mOutline = ActiveSheet.Shapes.AddShape(msoShapeRectangle, SelectedArea.Left, SelectedArea.Top, SelectedArea.Width, SelectedArea.Height)
With mOutline.OLEFormat.Object.ShapeRange
.Fill.Visible = msoFalse
.Line.ForeColor.RGB = RGB(255, 0, 0)
.Line.Transparency = 0
.Line.Weight = 3
End With
mOutline.Name = SelectedShapeName
Next SelectedArea
On Error GoTo 0 End Sub
When I right-click on a column header in my worksheet, Excel suddenly stops working and exists.
Does anybody know what causes this error, and if so, how I can modify my code to avoid this?
Thank you.
Your code is attempting to add a shape that is too tall for Excel to handle. When you right-click, it is selecting the entire column, so SelectedArea.Top is 0 and SelectedArea.Height is some absurdly large number (15728640 on my machine). That is causing ActiveSheet.Shapes.AddShape to fail.
Remove the On Error Resume Next line entirely. You're ignoring the 1004 error instead of handling it. Then the next line of code attempts to dereference an OLEObject that doesn't exist (which would be the second ignored error), and then attempts to assign a property to the null reference (which would be the third ignored error). I'm not going to test to find out which one is bringing Excel down, but I would guess that either the 2nd or 3rd one is causing an access violation.
Either add proper error handling, or better, avoid the error by testing to see if you have a valid Target:
'Assuming you want to limit to one cell
If Target.Rows.Count > 1 Or Target.Columns.Count > 1 Then Exit Sub
Related
This question already has answers here:
What are the rules governing usage of parenthesis in VBA function calls?
(8 answers)
Excel vba runtime error 424 Object required when assigning Range variable
(2 answers)
Closed 4 months ago.
As in the below three sub procedures, i intend to set the color (and the fonts and other more not shown here in the sample codes, but the issue remains the same) of a range when some conditions are met . Calling directly the Sub Set_Range_YELLOW_Color from my main working Sub has no error, and the code line works fine. But when i tried to call a procedure that makes a call to Set_Range_YELLOW_Color , i got an error message: Run-time Error '424' Object required. The error appears within the Do_Unapprouved_Work_MarkUp procedure at the line calling Set_Range_YELLOW_Color highlighted.
I still can not figure out my wrong. Thanks for anyone who can help thru this.
Private Sub Set_Range_YELLOW_Color(myRange As Range)
With myRange.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = RGB(255, 255, 193)
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End Sub
Private Sub Do_Unapprouved_MarkUp(myRange As Range)
Set_Range_YELLOW_Color (myRange) ' Error appears here and this line is highlighted
End Sub
Sub test2()
' Sheets("--BROUILLON--").Select
Set_Range_YELLOW_Color (ThisWorkbook.Worksheets("--BROUILLON--").Range("AA10"))
Do_Unapprouved_MarkUp (ThisWorkbook.Worksheets("--BROUILLON--").Range("AA11"))
End Sub
Defining a local range object Dim aRange As Range in the Do_Unapprouved_Work_MarkUp sub, and using Set aRange = myRange , and then calling the coloring Sub Set_Range_YELLOW_Color , it does not work either. It gives the exact same error at the same line.
Private Sub Do_Unapprouved_MarkUp(myRange As Range)
Dim aRange As Range
Set aRange = myRange
Set_Range_YELLOW_Color (aRange) ' Error appears here and this line highlighted
End Sub
When i call the fromatting procedure directly the code works well. But that makes me rewrite many many times a set of formatting codes that i would like to congregate as much as possible.
I expect to find the way to call the Set_Range_YELLOW_Color indirectly thru a third Sub procedure , from the main Sub procedure.
How can I resolve the type mismatch error (indicated)?
If I want to restrict the sub to the specified ranges, why would changing If Not Intersect to If Intersect exit the sub?
Private Sub Workbook_SheetBeforeDoubleClick(ByVal sH As Object, ByVal Target As Range, Cancel As Boolean)
' Exclude specified ranges
Dim rExcl(1) As Range, i As Integer, r As Range
Set rExcl(0) = Range("Table1"): Set rExcl(1) = Range("Table2")
For i = 0 To 1
For Each r In rExcl(i)
If r.Parent Is sH Then
If Not Intersect(Target, r) Is Nothing Then Exit Sub ' Type mismatch error
End If
Next
Next
End Sub
It seems that the purpose of the code posted is to validate if the user double-clicked a cell within any of the Tables (i.e.: Table1 or Table2), if so then Exit Sub.
In regards to the questions:
1. How can I resolve the type mismatch error (indicated)?
If Not Intersect(Target, r) Is Nothing Then Exit Sub ' Type mismatch error
Unfortunately, this error cannot be reproduced. This error is triggered when the data type of a variable differs to what is required. In this case it seems "almost" impossible because:
Intersect expects ranges and both variables (Target and r) are defined as ranges.
Intersect returns an object (range) which is what Is Nothing is expecting.
Intersect could also return an Error when the ranges have different parents, but that situation is already taken care by this line If r.Parent Is Sh Then.
The proposed solution includes a method to debug this error when it happens.
2. If I want to restrict the sub to the specified ranges, why would changing If Not Intersect to If Intersect exit the sub?
This is happening because the code posted is validating the ranges cell by cell, therefore if the user double-clicked the last cell of the table then the code compares the first cell and because there is no intersection the code exits the sub.
Bear in mind that the purpose is to validate if the double-clicked cell belongs or not to any of the tables ( i.e.: “ranges intersection”, if one cell intersect or not with a range, then the entire range intersects or not), as such there is no need to validate each cell, instead validate the entire range at once.
Proposed Solution:
Note that the ERR_Intersect subroutine should be just temporary, it is include to help analyze the mismatch error.
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim rExcl(1) As Range, vRng As Variant
Set rExcl(0) = Range("Table1")
Set rExcl(1) = Range("Table2")
For Each vRng In rExcl
Rem Validate Worksheet
If vRng.Parent Is Sh Then
Rem Validate Target
On Error Resume Next
If Not Intersect(Target, vRng) Is Nothing Then
blErr = Error.Number <> 0
On Error GoTo 0
If blErr Then GoTo ERR_Intersect
Exit Sub
End If
On Error GoTo 0
End If: Next
Exit Sub
ERR_Intersect:
Debug.Print vbLf; "Error: "; Err.Number; " - "; Err.Description
Debug.Print "Object"; Tab(11); "TypeName"; Tab(21); "Address"; Tab(31); "Parent"
Debug.Print "Target"; Tab(11); TypeName(Target);
Debug.Print Tab(21); Target.Address(0, 0);
Debug.Print Tab(31); Target.Parent.Name;
Debug.Print
Debug.Print "vRng"; Tab(11); TypeName(vRng);
Debug.Print Tab(21); vRng.Address(0, 0);
Debug.Print Tab(31); vRng.Parent.Name;
Debug.Print
MsgBox "Error: " & Err.Number & " - " & Err.Description & vbLf & _
vbTab & "See Immediate Window for details."
Exit Sub
End Sub
Your code works without any problem in the way you presented and it will also work in the way you try understanding, but with a different meaning, respectively:
You should understand that Intersect returns a 'Range' and the above code checks if this Range exists. In words, this part should be understood as "If the two ranges are intersecting".
This part If Intersect(Target, r) Is Nothing Then Exit Sub means "If the two ranges are not intersecting" (such an eventual intersection does not exist).
No any 'Type mismatch' should exist in both mentioned variants, if you are referring to real tables. It may appear if you named a different object (not a range) as 'TableX'...
Please, try inserting the next code line:
Debug.Print TypeOf rExcl(0) Is Range, TypeOf rExcl(1) Is Range: stop
after:
Set rExcl(0) = Range("Table1"): Set rExcl(1) = Range("Table2")
What does it return in Immediate Window?
Edited:
You could not 'reproduce the error in Debug.Print' because that line is not even reached...
There is a conflict in your workbook. There is the Workbook event you show us in the question and another Worksheet_BeforeDoubleClick event which tries closing the Excel application if the double clicked cell is the one you claim as being 'strange'...
The sheet event is triggered first and the Workbook one is not triggered anymore, since the code tries quitting Excel application. Try put Exit Sub as the first code line in the Worksheet event and try the double click again.
Nothing wrong will happen after that...
I am using this code to highlight the selected cell and it works fine. However, I was wondering if there is a better way of doing it without using On error resume next.
Also, If I use this statement does that mean other errors in the same event or procedures called by the event would not be catched?
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Union(Me.Range("range_name"), Me.Range("range_name2"), _
Me.Range("range_name3"))) Is Nothing Then
Static xLastRng As Range
On Error Resume Next
Target.Interior.ColorIndex = 6
xLastRng.Interior.ColorIndex = xlColorIndexNone
Set xLastRng = Target
End If
End Sub
Here is another approach, because right now you are inputing a fill color instead of conditional formatting. You might ruin other cells their format doing so.
What I done is for example use this conditional formatting rule on column C, D and E (you have other ranges so use them accordingly).
=AND(ROW()=CELL("ROW"),COLUMN()=CELL("COLUMN"))
This alone should do the trick, but it's some kind of glitch (too fast) for the screen to properly update the selected cell with a conditional format. Scrolling down and back up fixes this and you will see that the selected cell is formatted if it is within your ranges.
To counter this I used a forced waiting time on a selection change in the worksheet untill Excel is done calculating...
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.ScreenUpdating = False
If Not Application.CalculationState = xlDone Then
DoEvents
End If
Application.ScreenUpdating = True
End Sub
No you will notice that it will not glitch out :)
If the glitch doesn't happen on your side, you can leave out the VBA part.
Try this:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static xLastRng As Range
Dim rng As Range
Set rng = Application.Intersect(Target, Union(Me.Range("range_name"), _
Me.Range("range_name2"), _
Me.Range("range_name3")))
'clear previous range hilite first, since overlap
' between previous & new could occur
If Not xLastRange Is Nothing Then
xLastRng.Interior.ColorIndex = xlColorIndexNone
Set xLastRange = Nothing
End If
If Not rng Is Nothing Then
Target.Interior.ColorIndex = 6
Set xLastRange = rng
End If
End Sub
It's unclear from your question whether you'd want to clear any previous highlighting if a new selection falls outside of your checked ranges.
I like this one!!
http://www.cpearson.com/excel/RowLiner.htm
Simply point to the Excel AddIn and run it.
https://trumpexcel.com/excel-add-in/
I have created a Userform with several option buttons as part of a larger macro. The UserForm will load if there is a specific calculation error and will ask the user to select a method to correct the error. One option enables a RefEdit control and allows the user to select a new starting cell (and skip the errors and cells between the current and newly defined range).
I have used the _Exit event to set up some error checking (e.g. to ensure a valid range is selected or to ensure the range is a 1x1 range), but I have been unable to find a way to force the RefEdit control to "reinitialize." I have tried using the RefEdit.SetFocus method but this is not producing the result I want.
Basically, is there a command I can use that mirrors the act of clicking the dropbutton on the RefEdit control?
Private Sub RefEdit_NewStartCell_Exit(ByVal Cancel As MSForms.ReturnBoolean)
On Error Resume Next
Set UserRange = Range(RefEdit_NewStartCell.Text)
If Err.Number <> 0 Then
MsgBox "Invalid range selected"
RefEdit_NewStartCell.SetFocus
End If
On Error GoTo 0
This is not a "real" answer, but a workaround (most times excel crashed using a RefEdit, so i could not run tests... sorry)
Do it with your RefEdit if u want (i have used a textbox):
Private Sub TextBox1_Enter()
On Error Resume Next
Set UserRange = Nothing
UserForm1.Hide
While UserRange.Count <> 1
Set UserRange = Application.InputBox("Select Range", , , , , , , 8)
Wend
CommandButton1.SetFocus
TextBox1.Value = UserRange.Address
UserForm1.Show
End Sub
Hopefully someone got a better answer soon ^.^;
At least the inputbox will only return a valid range (no need to check that)
so I have been searching through this forum for quite a while now, and also on other sites, but I just could not find a way to solve this problem.
So the small problem I got is, that I have a very long Excel Spreadsheet, with many different ID's, or numbers whatever you want to call them. From these ID's I create a custom link, which needs them to direct to a specific image, that is then pasted into a specific cell in this spreadsheet. Note that I really need this code, hence the spreadsheet is about 9300 lines/rows long. The problem now is that not every id has an image attached to it, which means that some links do not work (no image there, but also no text basically an empty page). Is there a way I can just let the code run through it, so that it ignores the error 1004 which is generated, which basically is always telling me he could not find something and will stop at that point.
I am a big noob at VBA, so please when answering do not use to complicated language. I will paste the code below, however the link is confidential, so I will replace the link with "link" or something like that. I tried several On Error methods, but either the error came up again, or Excel crashed, but here is the working code without any modifications to remove this error. Thanks in advance for all the help.
Sub Test()
I = 0
For I = 5 To 9373
If Tabelle2.Cells(I, 9) = "bekannt" Then
Call GetShapeFromWeb("Part 1 of the link" & Tabelle2.Cells(I, 10).Value & "Part 2 of the link", Tabelle2.Cells(I, 13))
End If
Next I
End Sub
Sub GetShapeFromWeb(strShpUrl As String, rngTarget As Range)
Dim shp As Shape
With rngTarget
With .Parent
.Pictures.Insert strShpUrl 'Error Occurs here
Set shp = .Shapes(.Shapes.count)
End With
shp.Left = .Left
shp.Top = .Top
End With
Set shp = Nothing
End Sub
One last thing to notice, some of the words are german, due to me being german and working with german variables, or links, or spreadsheets. And I am using excel 2007. The Error occurs in the following row ".Pictures.Insert strShpUrl" because it can not find a picture to insert.
Thansk a lot.
Kind Regards
Chris
//EDIT
One Idea I might have, which I dont know if it is possible, but the page it is directed to, when a picture is not there it displays the following "Unable to find /part/of/thelink/"
Could one maybe use a code to see if this message is displayed, and maybe check for that? If so how would that work? :) Maybe it could be added to the if statement at the top which tests already for this sub task.
//EDIT
Anyone got some idea? :S Maybe what I posted above in the edit could work? :S Is it possible to check if a msgbox displays something but the other way around so if the msgbox does not equal the following do this. If that could work it would be great! :S Or maybe instead of trying the on error commands trying it with an if statement within the GetShapeFromWeb sub? Any help is greatly appreciated.
This should work. However you wrote that you tried several On Error Methods unsuccessfully ... what does this one for you?
Sub GetShapeFromWeb(strShpUrl As String, rngTarget As Range)
Dim shp As Shape
Dim Er As Long: Er = 0
On Error GoTo gswError
With rngTarget
With .Parent
.Pictures.Insert strShpUrl
If Er <> 0 Then Exit Sub
Set shp = .Shapes(.Shapes.Count)
End With
shp.Left = .Left
shp.Top = .Top
End With
Set shp = Nothing
Exit Sub
gswError:
Er = Err
Resume Next
End Sub
have you tried on the GetShapeFromWeb sub, placing the On Error statement this way:
Sub GetShapeFromWeb(strShpUrl As String, rngTarget As Range)
Dim shp As Shape
On Error GoTo Err1 'inserting a picture from a blank link will cause an error... thus...
With rngTarget
With .Parent
.Pictures.Insert strShpUrl
Set shp = .Shapes(.Shapes.Count)
End With
shp.Left = .Left
shp.Top = .Top
End With
Err1: '...sidestep
Set shp = Nothing
End Sub