I created a macro for Excel which opens a list of all visible sheets in a workbook and goes to the desired sheet as you scroll through the list. The idea is to avoid using the mouse as much as possible.
I am forced to scroll down starting from the first item in the list.
I would like to instead "start" from the initial sheet (wherever it may be) so I can scroll up/down depending on what sheet I would like to open.
In other words,
I would like the listbox to populate with all visible sheets
I would like the starting point for the user to be the active sheet so they can scroll up/down from their starting point
Code for the listbox:
Private Sub CommandButton1_Click()
Unload ListBox
End Sub
Private Sub UserForm_Initialize()
Dim WS As Worksheet
For Each WS In Worksheets
ListBox1.AddItem WS.Name
Next WS
End Sub
Private Sub ListBox1_Click()
Sheets(ListBox1.Value).Activate
End Sub
Code which opens the listbox:
Public Sub ShowUserForm()
Load ListBox
ListBox.Show
Debug.Print "===="
Debug.Print
End Sub
another one...
Private Sub UserForm_Initialize()
Dim ws As Worksheet, idx As Long
With Me.ListBox1
For Each ws In ActiveWorkbook.Worksheets
If ws.Visible = xlSheetVisible Then
.AddItem ws.Name
If ws Is ActiveSheet Then
idx = .ListCount - 1 ' item indexes start at zero
End If
End If
Next
.ListIndex = idx '
End With
End Sub
Private Sub ListBox1_Change()
Worksheets(ListBox1.Value).Activate
End Sub
You mentioned "all . . . sheets", if you want to include Chart sheets loop Each objSheet in Sheets and in the change event replace Worksheets with Sheets
what's about that:
Private Sub UserForm_Initialize()
Dim wksTab As Worksheet
For Each wksTab In ThisWorkbook.Worksheets
If wksTab.Visible = xlSheetVisible Then
If wksTab.Name <> ActiveSheet.Name Then
Me.ListBox1.AddItem wksTab.Name
End If
End If
Next wksTab
Me.ListBox1.AddItem ActiveSheet.Name
Me.ListBox1.ListIndex = Me.ListBox1.ListCount - 1
End Sub
Best regards
Bernd
Hy, I have an excel workbook consisting an Excel Sheet which contains images, shapes, arrows and many more shapes. The structure of the sheet looks like this.
In the above picture, I circle all the textboxes, arrows, Ovels, shapes which I want to delete. I have written a code to delete text boxes which are checking the existence of textboxes and if found delete them. In the other hand, if not exist show pop-up that text-box, does not exist. The code is as under.
Sub resetall()
Dim ws As Worksheet
Dim arow As Shapes
Dim txtbox As TextBox
Set ws = ActiveSheet
If ws.TextBoxes.Count < 0 Then
MsgBox "No Text Box Exist."
Exit Sub
End If
ws.TextBoxes.Delete
MsgBox "Text Box has been deleted successfully."
End Sub
This code is working fine, but I could not find the code for Arrows, and Oval Shapes, and Circles. Please check my code and guide me. I tried to use the shapes. Oval reference from the library but could not succeed. Please guide me. Thank you.
https://www.thespreadsheetguru.com/the-code-vault/vba-delete-all-shapes
Sub DeleteAllShapes()
'PURPOSE: Remove All Shape Objects From The Active Worksheet
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
shp.Delete
Next shp
End Sub
Optionally, add a test inside the loop for a specific type from msoShapeType
Try the next code, please:
Sub DeleteallShapesExceptRect()
Dim ws As Worksheet, s As Shape, boolRect As Boolean
Set ws = ActiveSheet
For Each s In ws.Shapes
If s.Type = msoAutoShape Then
If s.AutoShapeType = msoShapeRectangle Then
boolRect = True
End If
End If
If Not boolRect Then s.Delete
boolRect = False
Next
The next variant excepts any Rectangle shape type:
Sub DeleteallShapesExceptAllRect()
Dim ws As Worksheet, s As Shape, boolRect As Boolean
Set ws = ActiveSheet
For Each s In ws.Shapes
If s.Type = msoAutoShape Then
If s.AutoShapeType = msoShapeRectangle Or _
msoShapeRoundedRectangle Or msoShapeRound1Rectangle Or _
msoShapeSnip2DiagRectangle Then
boolRect = True
End If
End If
If Not boolRect Then s.Delete
boolRect = False
Next
End Sub
The following variant deletes all shapes from a specific range:
Sub DeleteAllShapesOnRange()
Dim ws As Worksheet, s As Shape, rngDel As Range
Set ws = ActiveSheet: Set rngDel = ws.Range("A1:W6")
For Each s In ws.Shapes
If Not Intersect(rngDel, s.TopLeftCell) Is Nothing Then
s.Delete
End If
Next
End Sub
And the next one deletes all shapes which are Not on the specific range:
Sub DeleteAllShapesNotOnRange()
Dim ws As Worksheet, s As Shape, rngNoDel As Range, boolFound As Boolean
Set ws = ActiveSheet: Set rngNoDel = ws.Range("A1:W6")
For Each s In ws.Shapes
If Not Intersect(rngNoDel, s.TopLeftCell) Is Nothing Then
boolFound = True
End If
If Not boolFound Then s.Delete
Next
End Sub
And finally, a version deleting all shapes not having text:
Sub DeleteAllShapesNotHavingText()
Dim ws As Worksheet, s As Shape, boolFound As Boolean
Set ws = ActiveSheet
For Each s In ws.Shapes
If Not Len(s.TextFrame2.TextRange.Text) = 0 Then
boolFound = True
End If
If Not boolFound Then s.Delete
Next
End Sub
Note: Each such a code is able to ask for permission before deletion, but it will not make big difference between the manual deletion and the one done in code... If you insist to have such a condition, please specify which of the above versions to be adapted.
Anyhow, the next Sub returns (in Immediate Window) all (mentioned) shapes type. You can change their names. The following code check their real type, which is returned like Long:
Sub EnumerateShapesType()
Dim ws As Worksheet, s As Shape, boolRect As Boolean, arrS As Variant, arrEl As Variant, El As Variant
arrS = Split("Rectangle|1,Round Rectangle|5,Oval|9,Right Arrow|33,Down Arrow|36", ",")
Set ws = ActiveSheet
For Each s In ws.Shapes
If s.Type = msoAutoShape Then
For Each El In arrS
If s.AutoShapeType = Split(El, "|")(1) Then
Debug.Print s.Name, Split(El, "|")(0): Exit For
End If
Next
End If
Next
End Sub
Office 365 answer:
Go to the Home tab
Go to Find & Select
Go to Selection Pane
You now have the names of the shapes in your worksheet.
As an example, you could use ActiveSheet.Shapes.Range(Array("Straight Arrow Connector 1")).Delete to remove a single item.
I want to compress all the pictures in excel workbook to email size pixel 96( ppi) by using command button with the following code. But it doesn't work to compress all pictures .It can only compress 1 picture.
Sub test()
Dim wsh As Worksheet
Set wsh = Worksheets("Sheet1")
wsh.Activate
wsh.Shapes(1).Select
SendKeys "%e", True
SendKeys "~", True
Application.CommandBars.ExecuteMso "PicturesCompress"
End Sub
Try using a For Each loop to iterate through all shapes in the worksheet:
Sub test()
Dim wsh As Worksheet
Dim shp As Shape
Set wsh = Worksheets("Sheet1")
For Each shp In wsh.Shapes
shp.Select
SendKeys "%e", True
SendKeys "~", True
Application.CommandBars.ExecuteMso "PicturesCompress"
Next shp
End Sub
I would like to make the all specified shapes gone from more than 1 sheet. It applies roughly to the "Cables" sheets.
It's related with my previous query:
VBA Excel select & delete all shapes with the same ID and remove
According to my query regarding the PDF saving
VBA excel excluding specified sheets when saving the .PDF version
I prepared the code, which looks as follows:
Sub Firestopshapes()
Dim shp As Shape
Dim Ws As Worksheet
If Ws.Name Like "*Cables*" Then
'Set Ws = ActiveSheet
For Each shp In Ws.Shapes
If shp.Name = "Firestop" Then
shp.Delete
End If
Next shp
End If
End Sub
Unfortunately I am getting error:
Object variable or With block variable not set
What have I done wrong here?
To close this question out... you forgot the loop through all the worksheets:
For Each Ws in ThisWorkbook.Worksheets
If Ws.Name Like "*Cables*" Then
...
End If
Next
Consider:
Sub Firestopshapes()
Dim shp As Shape
Dim Ws As Worksheet
For Each Ws In Sheets
If InStr(Ws.Name, "Cables") > 0 And Ws.Shapes.Count > 0 Then
For Each shp In Ws.Shapes
If shp.Name = "Firestop" Then
shp.Delete
End If
Next shp
End If
Next Ws
End Sub
I want to disable buttons after they are clicked in Excel 2013.
My code works fine but for just one specific button.
How can apply the same logic to all buttons in a Sheet?
ActiveSheet.Shapes("Button 1").OnAction = Empty
ActiveSheet.Shapes("Button 1").DrawingObject.Font.ColorIndex = 16
It's not clear from your question whether you want pressing Button1 to "disable" all controls on the sheet, or whether you want each button to disable itself.
Button1 disables all controls
Sub Button1_Click
Dim shp As Shape
For Each shp In Sheet1.Shapes
With shp
If .Type = msoFormControl Then
.OnAction = ""
.DrawingObject.Font.ColorIndex = 16
End If
End With
Next shp
End Sub
Each button disables itself
Use a common button disabler helper procedure...
Sub Button1_Click()
DisableButton Sheet1, "Button 1"
End Sub
Sub Button2_Click()
DisableButton Sheet1, "Button 2"
End Sub
Sub DisableButton(hostSheet As Worksheet, shapeName As String)
Dim shp As Shape
On Error Resume Next
Set shp = hostSheet.Shapes(shapeName)
On Error GoTo 0
If Not shp Is Nothing Then
With shp
If .Type = msoFormControl Then
.OnAction = ""
.DrawingObject.Font.ColorIndex = 16
End If
End With
End If
End Sub
I would guess this is what you're looking for:
Sub Answer()
dim sh as shape
For Each Sh In ActiveSheet.Shapes
Sh.OnAction = Empty
Sh.DrawingObject.Font.ColorIndex = 16
Next
End Sub
This should hide all form control (including buttons) in the worksheet.
Dim ws_export As Worksheet
Dim shp_hide As Shape
For Each shp_hide In ws_export.Shapes
If shp_hide.Type = msoFormControl Then shp_hide.Visible = FALSE
Next shp_hide