Code work in 365 but not working in version 2013

C

ceecee88

Board Regular
Joined
Jun 30, 2022
Messages
59
Office Version
  1. 365
  2. 2013
Platform
  1. Windows
Hi, I asked the question before and already have the code working for selected all shapes from specific row downward, but the issue now is that it won't work in version 2013. It is show error message, not sure what the issue is. Please see the existing code below. Your suggestion will be much appreciated.

Thank you

1684581656988.png


VBA Code: 
Private Sub SelectShapes()
Dim shp As Shape, Lft As Integer, Rht As Integer, Bot As Integer
Lft = 999: Rht = 1: Top = 999

Application.ScreenUpdating = False
Worksheets("Sheet1").Select
For Each shp In ActiveSheet.Shapes
    If shp.TopLeftCell.Row > 6 Then
        Lft = Application.WorksheetFunction.Min(Lft, shp.TopLeftCell.Column)
        Top = Application.WorksheetFunction.Min(Top, shp.TopLeftCell.Row)
        Rht = Application.WorksheetFunction.Max(Rht, shp.BottomRightCell.Column)
        Bot = Application.WorksheetFunction.Max(Bot, shp.BottomRightCell.Row)
   
    End If
 
Next shp
 If Not (Lft = 999 And Top = 999) Then Range(Cells(Top - 2, Lft - 1), Cells(Bot + 2, Rht)).Select
 Application.ScreenUpdating = True
 
End Sub
 

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.
Sort by date Sort by votes
Hi @ceecee88

The problem is if the shape is in the first column, then you can't select cells in column 0, since there is no column 0.

Try the following:

Rich (BB code): 
Private Sub SelectShapes()
  Dim shp As Shape, Lft As Long, Rht As Long, Bot As Long, top As Long
  Lft = 999
  Rht = 1
  top = 999
 
  Application.ScreenUpdating = False
  Worksheets("Sheet1").Select
  For Each shp In ActiveSheet.Shapes
    If shp.TopLeftCell.Row > 6 Then
      Lft = Application.WorksheetFunction.Min(Lft, shp.TopLeftCell.Column)
      top = Application.WorksheetFunction.Min(top, shp.TopLeftCell.Row)
      Rht = Application.WorksheetFunction.Max(Rht, shp.BottomRightCell.Column)
      Bot = Application.WorksheetFunction.Max(Bot, shp.BottomRightCell.Row)
    End If
  Next shp
  If Not (Lft = 999 And top = 999) Then
    If Lft > 1 Then Lft = Lft - 1
    Range(Cells(top - 2, Lft), Cells(Bot + 2, Rht)).Select
  End If
  Application.ScreenUpdating = True
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​
 
Upvote 0
I can't edit the post anymore so I just wanted to add that the problem is also come at random time, some time is show error, sometimes the code run just fine.

Thank you
 
Upvote 0
DanteAmor said:
Hi @ceecee88

The problem is if the shape is in the first column, then you can't select cells in column 0, since there is no column 0.

Try the following:

Rich (BB code): 
Private Sub SelectShapes()
  Dim shp As Shape, Lft As Long, Rht As Long, Bot As Long, top As Long
  Lft = 999
  Rht = 1
  top = 999
 
  Application.ScreenUpdating = False
  Worksheets("Sheet1").Select
  For Each shp In ActiveSheet.Shapes
    If shp.TopLeftCell.Row > 6 Then
      Lft = Application.WorksheetFunction.Min(Lft, shp.TopLeftCell.Column)
      top = Application.WorksheetFunction.Min(top, shp.TopLeftCell.Row)
      Rht = Application.WorksheetFunction.Max(Rht, shp.BottomRightCell.Column)
      Bot = Application.WorksheetFunction.Max(Bot, shp.BottomRightCell.Row)
    End If
  Next shp
  If Not (Lft = 999 And top = 999) Then
    If Lft > 1 Then Lft = Lft - 1
    Range(Cells(top - 2, Lft), Cells(Bot + 2, Rht)).Select
  End If
  Application.ScreenUpdating = True
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​
Click to expand...
Wow! That's totally make sense why the error comes at random time. Thank you for your quick help, really appreciate it. I wouldn't have thought of this reason. I thought it was the version.

Thank you
 
Upvote 0
DanteAmor said:
Hi @ceecee88

The problem is if the shape is in the first column, then you can't select cells in column 0, since there is no column 0.

Try the following:

Rich (BB code): 
Private Sub SelectShapes()
  Dim shp As Shape, Lft As Long, Rht As Long, Bot As Long, top As Long
  Lft = 999
  Rht = 1
  top = 999
 
  Application.ScreenUpdating = False
  Worksheets("Sheet1").Select
  For Each shp In ActiveSheet.Shapes
    If shp.TopLeftCell.Row > 6 Then
      Lft = Application.WorksheetFunction.Min(Lft, shp.TopLeftCell.Column)
      top = Application.WorksheetFunction.Min(top, shp.TopLeftCell.Row)
      Rht = Application.WorksheetFunction.Max(Rht, shp.BottomRightCell.Column)
      Bot = Application.WorksheetFunction.Max(Bot, shp.BottomRightCell.Row)
    End If
  Next shp
  If Not (Lft = 999 And top = 999) Then
    If Lft > 1 Then Lft = Lft - 1
    Range(Cells(top - 2, Lft), Cells(Bot + 2, Rht)).Select
  End If
  Application.ScreenUpdating = True
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​
Click to expand...
Hi, sorry to bother you again, the code doesn't work yesterday but it is now randomly show the same error again, is there any further suggestion please?
Thank you
 
Upvote 0
You should test the code for each shape. And see which one have the problem.
Analyze the problem and check why that shape has the problem.

Try the following code to see which shape is having problems.
If there is a shape with an error, it will be selected and it will show you the name.
VBA Code: 
Private Sub SelectShapes()
  Dim shp As Shape, Lft As Long, Rht As Long, Bot As Long, top As Long
  Dim shName As String
  
  Lft = 999
  Rht = 1
  top = 999
 
  Application.ScreenUpdating = False
  Worksheets("Sheet1").Select
  For Each shp In ActiveSheet.Shapes
    If shp.TopLeftCell.Row > 6 Then
      
      shName = shp.Name
      shp.Select
      
      Lft = Application.WorksheetFunction.Min(Lft, shp.TopLeftCell.Column)
      top = Application.WorksheetFunction.Min(top, shp.TopLeftCell.Row)
      Rht = Application.WorksheetFunction.Max(Rht, shp.BottomRightCell.Column)
      Bot = Application.WorksheetFunction.Max(Bot, shp.BottomRightCell.Row)
      
      If Not (Lft = 999 And top = 999) Then
        On Error GoTo showshape
        If Lft > 1 Then Lft = Lft - 1
        Range(Cells(top - 2, Lft), Cells(Bot + 2, Rht)).Select
        On Error GoTo 0
      End If
    
    
    End If
  Next shp
  Application.ScreenUpdating = True
  
Exit Sub
showshape:
  MsgBox "Shape with problems: " & shName
End Sub

If you can't find the problem share your file, delete all sensitive information and share it to see why some shape has the problem.
Note share file:
You could upload a copy of your file to a free site such www.dropbox.com or google drive. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. If the workbook contains confidential information, you could replace it with generic data.
 
Upvote 0
DanteAmor said:
You should test the code for each shape. And see which one have the problem.
Analyze the problem and check why that shape has the problem.

Try the following code to see which shape is having problems.
If there is a shape with an error, it will be selected and it will show you the name.
VBA Code: 
Private Sub SelectShapes()
  Dim shp As Shape, Lft As Long, Rht As Long, Bot As Long, top As Long
  Dim shName As String
 
  Lft = 999
  Rht = 1
  top = 999
 
  Application.ScreenUpdating = False
  Worksheets("Sheet1").Select
  For Each shp In ActiveSheet.Shapes
    If shp.TopLeftCell.Row > 6 Then
     
      shName = shp.Name
      shp.Select
     
      Lft = Application.WorksheetFunction.Min(Lft, shp.TopLeftCell.Column)
      top = Application.WorksheetFunction.Min(top, shp.TopLeftCell.Row)
      Rht = Application.WorksheetFunction.Max(Rht, shp.BottomRightCell.Column)
      Bot = Application.WorksheetFunction.Max(Bot, shp.BottomRightCell.Row)
     
      If Not (Lft = 999 And top = 999) Then
        On Error GoTo showshape
        If Lft > 1 Then Lft = Lft - 1
        Range(Cells(top - 2, Lft), Cells(Bot + 2, Rht)).Select
        On Error GoTo 0
      End If
   
   
    End If
  Next shp
  Application.ScreenUpdating = True
 
Exit Sub
showshape:
  MsgBox "Shape with problems: " & shName
End Sub

If you can't find the problem share your file, delete all sensitive information and share it to see why some shape has the problem.
Note share file:
You could upload a copy of your file to a free site such www.dropbox.com or google drive. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. If the workbook contains confidential information, you could replace it with generic data.
Click to expand...
Hi, thank you for your help, quick question please. I just want to understand the meaning of the error first.

The error is in this line
If shp.TopLeftCell.Row > 6 Then
I tried your code but it still stuck at that line not even go to showshape:

Do you think it is error because of the shape or may be something about the TopLeftCell?

Thank you
 
Upvote 0
ceecee88 said:
show the same error again
Click to expand...
Please note: When you post an error, you should put the error message and on which line you have the error.
That will help fix the problem.

----------------------------------------​

Some shape has other types of problems and I cannot know it, since in my tests my shapes have no problems. And since you don't share your file, we can only speculate.

Now, execute the following macro, but step by step by pressing F8 (debug mode), so that the macro goes through all the shapes one by one, the macro will stop at the shape with error.

So when the macro stops, check that shape and see what the problem is or just delete it and continue with the next one to discard all the shapes that have problems.

VBA Code: 
Private Sub SelectShapes_v2()
  Dim shp As Shape
  Dim shName As String
  
  Worksheets("Sheet1").Select
  For Each shp In ActiveSheet.Shapes
    
    On Error GoTo showshape
    shp.Select
    shName = shp.Name
    If shp.TopLeftCell.Row > 6 Then
    End If
    
  Next shp
  
Exit Sub
showshape:
  MsgBox "Shape with problems: " & shName
End Sub
 
Upvote 0
DanteAmor said:
Please note: When you post an error, you should put the error message and on which line you have the error.
That will help fix the problem.

----------------------------------------​

Some shape has other types of problems and I cannot know it, since in my tests my shapes have no problems. And since you don't share your file, we can only speculate.

Now, execute the following macro, but step by step by pressing F8 (debug mode), so that the macro goes through all the shapes one by one, the macro will stop at the shape with error.

So when the macro stops, check that shape and see what the problem is or just delete it and continue with the next one to discard all the shapes that have problems.

VBA Code: 
Private Sub SelectShapes_v2()
  Dim shp As Shape
  Dim shName As String
 
  Worksheets("Sheet1").Select
  For Each shp In ActiveSheet.Shapes
  
    On Error GoTo showshape
    shp.Select
    shName = shp.Name
    If shp.TopLeftCell.Row > 6 Then
    End If
  
  Next shp
 
Exit Sub
showshape:
  MsgBox "Shape with problems: " & shName
End Sub
Click to expand...
I tested your V2 code and it show the problem with the shape that is outside of the area, for example it should check for shape in row 6 and below but the problem shape is in row 2 which should be irrelevant. Why is that?

Thank you so much.
 
Upvote 0
Since we haven't been able to figure out what causes some shapes to have errors, so let's skip all the errors, please try again with this code and see if it works.

VBA Code: 
Private Sub SelectShapes()
  Dim shp As Shape, Lft As Long, Rht As Long, Bot As Long, top As Long
  Lft = 999
  Rht = 1
  top = 999
 
  Worksheets("Sheet1").Select
  On Error Resume Next
  
  For Each shp In ActiveSheet.Shapes
    If shp.TopLeftCell.Row > 6 Then
      Lft = Application.WorksheetFunction.Min(Lft, shp.TopLeftCell.Column)
      top = Application.WorksheetFunction.Min(top, shp.TopLeftCell.Row)
      Rht = Application.WorksheetFunction.Max(Rht, shp.BottomRightCell.Column)
      Bot = Application.WorksheetFunction.Max(Bot, shp.BottomRightCell.Row)
    End If
  Next shp
  
  If Not (Lft = 999 And top = 999) Then
    If Lft > 1 Then Lft = Lft - 1
    Range(Cells(top - 2, Lft), Cells(Bot + 2, Rht)).Select
  End If
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Locked
  • Question
" this image cannot currently be displayed" from excel to adobe icloud
Replies
1
Views
1K
Fluff
Fluff
J
  • Question
Reducing workbook file size
2
Replies
11
Views
2K
johnnyL
J
L
  • Question
VBA works on work PC but not home PC
Replies
3
Views
2K
rollis13
rollis13
ajjava
  • Question
Looking for some assistance in tweaking this code (that another forum user graciously helped me with)
Replies
0
Views
883
ajjava
ajjava
A
  • Question
Excel files have objects that can not be deleted
2
Replies
11
Views
3K
sandy666
sandy666

Forum statistics

Threads
1,215,759
Messages
6,126,728
Members
449,332
Latest member
nokoloina

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top