I have a spreadsheet which contain several hyperlinks, some of which are from shapes. I am trying to loop through them, to see where each of them point in order to later remove some of them. For the hyperlinks contained in cells the following loop has worked:
Sub a()
Dim ws As Worksheet, hl As Hyperlink, o As Shape
For Each ws In Worksheets
For Each hl In ws.Hyperlinks
Debug.Print hl.Address
Next
Next
End Sub
But that seems to skip all the hyperlinks originating from shapes or other objects.
Is there any way I can loop through those as well? I have tried stuff like:
Sub a()
Dim ws As Worksheet, hl As Hyperlink, o As Shape
For Each ws In Worksheets
For Each o In ws.Shapes
For Each hl In o.Hyperlinks
Debug.Print hl.Address
Next
Next
Next
End Sub
But that gives me a runtime error 91 on the debug.print line. Googling gives me nothing. So, have any of you got an idea of how to print the addresses?
A Shape doesn't have a .Hyperlinks property, only a .Hyperlink one and you'll get an error from it if there is no associated hyperlink, so you need an error handler. For example:
On Error Resume Next
Set hl = o.Hyperlink
On Error GoTo 0
If Not hl Is Nothing Then
Debug.Print hl.Address
set hl = Nothing
End If
Related
I write the code below in ppt vba, for taking, in each slide, each shapes height, top, left, width paramateres. Then my idea is to copy the same paramateres in vba from excel for copying and pasting the OLEObjects to the exact same places on the slide. But gives error on mentioned line below. Any ideas why?
I am looking for a reason, why it gives the error;
For each sh In ActivePresentation.Slides.Shapes.
The data member or method was not found..
Sub chngshp()
Dim sl As Slides
Dim sh As Shapes
Set sl = ActivePresentation.Slides
Set sh = ActivePresentation.Shapes
For each sl In ActivePresentation
For each sh In ActivePresentation.Slides.Shapes
Debug.Print ActivePresentation.Slides.Shapes.Name
Debug.Print ActivePresentation.Slides.Shapes.Height
Next
Next
End Sub
The set statements are not needed. Here's how your code should be written:
Sub chngshp()
Dim sl As Slide
Dim sh As Shape
For each sl In ActivePresentation.Slides
For each sh In sl.Shapes
Debug.Print sh.Name
Debug.Print sh.Height
Next sh
Next sl
End Sub
I have an excel macro used to manage button visibility in Excel in the "Worksheet_Change" function based from another SO question here.
The problem is the although the macro works it makes updating the Excel sheet rather laggy. I have managed to pin down the slowness to a single line:
Set rUpdated = Range(Target.Dependents.Address)
This sets the range of cells updated to a variable to be iterated through later in the script. If I call a script with just this line I found this is where all the delay is. It seems a rather simple line, but is there a better way to do it?
Full disclosure:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rUpdated As Range
Dim shp As Shape
Dim rCell As Range
Set rUpdated = Range(Target.Dependents.Address)
If Not rUpdated Is Nothing Then
For Each rCell In rUpdated
If rCell.Column = 1 Then
'Look at each shape in the sheet and cross-reference with rCell.
For Each shp In Target.Parent.Shapes
If shp.TopLeftCell.Row = rCell.Row Then
shp.Visible = (rCell.Value <> "")
Exit For 'Exit the loop - the correct button has been found.
End If
Next shp
End If
Next rCell
End If
End Sub
So if i understood it correctly you want to make a button visible if the cell in the row as been changed. The only things i can think of to slow it down are, that is has to check many rCell or Shapes. I dont know what the structure of your document is. So my Idea would be: instead of going through all shapes every time, i would name them in a pattern that you can identify them with the row they are in so you use the name to address them (i.e Row2 for the Button in Row 2).
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rUpdated As Range
Dim shp As Shape
Dim rCell As Range
Dim obj As OLEObject
Set rUpdated = Range(Target.Dependents.Address)
If Not rUpdated Is Nothing Then
For Each rCell In rUpdated
If rCell.Column = 1 Then
On Error Resume Next
Set obj = ActiveSheet.OLEObjects("Row" & rCell.Row)
If Err.Number = 0 Then
obj.Visible = (rCell.Value <> "")
End If
End If
Next rCell
End If
End Sub
I replaced that config with the following single line (and companion line):
On Error Resume Next
ActiveSheet.Shapes("buttonRow" & Target.Row).Visible = (ActiveSheet.Cells(Target.Row, 1).Value <> "")
However to get this to work I first needed to rename all my shapes. I used this function to do that:
Function renamebuttons()
For Each shp In ActiveSheet.Shapes
shp.name = "buttonRow" & shp.TopLeftCell.Row
Next shp
End Function
I ran that function once and deleted it. Once done my shapes can now be referred to by name and I no longer incur the delay of cycling through every shape and every target dependent. The delay experienced in the worksheet is now minimal.
I have a sheet that organizes, stylizes, and summarizes data, and then copies itself and saves another copy as a .PDF.
On the original sheet, there are 3 "Buttons" made out of groups of shapes to run different macros ("Reset", "Fix Missing Employees", "Print and Email Summary". The problem is in deleting them on the copy. This is from a recorded macro:
ActiveSheet.Shapes.Range(Array("Group 2")).Select
Selection.Delete
I want to select/delete ALL shapes. I can't use "shapes.select", "shapes.delete", or anything else I've found help for. Every attempt beside the code listed above results in "Error 438 -- Object doesn't support this property or method" and it highlights that portion of the code.
How can I select/delete all shapes in a worksheet/book? (Using Excel 2010)
You do not need to select all the Shapes in a worksheet to delete them. A loop will do:
Sub ShapeKiller()
Dim sh As Shape
MsgBox ActiveSheet.Shapes.Count
For Each sh In ActiveSheet.Shapes
sh.Delete
Next sh
End Sub
You can delete more than one Shape at the same time. Here is an example that finds a certain row and deletes all the Shapes whose upper corner is in that row:
Sub ShapePickerAndKiller()
Dim s As Shape, sr As ShapeRange
Dim Arr() As Variant
Set mycell = Range("A:A").Find(What:=0, After:=Range("A1"))
rrow = mycell.Row
i = 1
For Each s In ActiveSheet.Shapes
If s.TopLeftCell.Row = rrow Then
ReDim Preserve Arr(1 To i)
Arr(i) = s.Name
i = i + 1
End If
Next s
Set sr = ActiveSheet.Shapes.Range(Arr)
sr.Select
Selection.Delete
End Sub
See older post
Here's the final solution I used:
Dim sh As Shape
For Each sh In ActiveSheet.Shapes
If sh.Type <> msoPicture Then
sh.Delete
End If
Next sh
The reason is because I had one shape I wanted to keep, with a logo of the company--The Shape Object approach made it very easy to handle this, because of the Shape.Type attribute (As one shape was a msoPicture, and the rest were msoRoundedRectangles). Also helpful, had there been one picture I wanted to delete would have been Shape.Name to name the one to delete or skip.
Shout out to #Gary's Student for pointing me down this path!
Hi there i have this code which changes cells with reference errors to white fonts. However i could only do so for a single sheet. range. How do i change the for each loop to loop for all the worksheets in the workbook? I used this code below but it does not seem to work!
Sub Delete_ref_basedontextcondition()
Dim R As Range
'Set rng = Nothing
On Error Resume Next
Set R = Application.InputBox("Select cells To be deleted", Type:=8)
Dim rng As Range
If TypeName(R) <> "Range" Then
Exit Sub
Else
R.Delete
End If
For k = 1 To ThisWorkbook.Worksheets.Count 'runs through all worksheets
Set wks = ThisWorkbook.Worksheets(k)
For Each cell In wks
If cell.Text = "#REF!" Then
cell.Font.Color = RGB(255, 255, 255)
End If
Next
Next
End Sub
While I disagree with your method of hiding #REF! errors rather than dealing with them so that they are not #REF! errors (or deleting the formulas that are creating them, here is some standard 'loop-through-the-worksheets' code that you should be able to adapt for your purposes.
Sub bad_ref()
Dim w As Long, ref As Range
On Error Resume Next
For w = 1 To Worksheets.Count
With Worksheets(w)
For Each ref In .Cells.SpecialCells(xlCellTypeFormulas, xlErrors)
If ref.Text = "#REF!" Then
ref.Font.ColorIndex = 2
'ref.clear '<~~this clears formatting, formulas. etc from the rogue cell.
End If
Next ref
End With
Next w
End Sub
It should run through quickly enough. Rather than examine every cell on each worksheet, I've narrowed down the cells to be critiqued with the Range.SpecialCells method, looking only through the formulas that produce errors. Something like a #N/A error will be left alone.
I've left an option to actually do something with the errors as a commented line.
i have designed a few codes to help remove reference errors however it does not automatically delete until i assign the macro to a button. i do not want it that way as it would seem unpleasant when i want to present the programme to my team members, and having to remove the errors on the spot with a button. I thought of combining my delete cells code and remove reference cell codes together so that they would run simultaneously but to no avail. Is it possible to combine these two codes to achieve my objective or are there any solutions or coding to remove/hide reference errors automatically? Here are the two codes. All of your help would be very much appreciated!
Sub deletetry2()
Dim R As Range
Set rng = Nothing
On Error Resume Next
Set R = Application.InputBox("Select cells To be deleted", Type:=8)
If TypeName(R) <> "Range" Then
Exit Sub
Else
R.Delete
End If
End Sub
Sub Check_ReferenceDeletecolumn()
Dim rng As Range
Dim rngError As Range
Set rng = Sheets("Sheet3").Range("A1:G100")
On Error Resume Next
Set rngError = rng.Cells.SpecialCells(xlCellTypeFormulas, xlErrors)
On Error GoTo 0
If Not rngError Is Nothing Then
rngError.EntireColumn.Delete
'delete means cells will move up after deleting that entire row
End If
End Sub
If the objective is to remove all rows containing errors, from a user defined range, this should work:
Option Explicit
Public Sub cleanUserDefinedRange()
Dim response As Range
On Error Resume Next
Set response = Application.InputBox("Select range to clean up errors", Type:=8)
If Not response Is Nothing Then cleanUpErrors response
On Error GoTo 0
End Sub
'------------------------------------------------------------------------------------------
Private Sub cleanUpErrors(ByRef rng As Range)
Application.ScreenUpdating = False
rng.SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete
Application.ScreenUpdating = True
End Sub