Best Way To Delete All Shapes And Adjacent Cell?

Lewzerrrr

Active Member
Joined
Jan 18, 2017
Messages
256
If I have images through B1:B10 and values in A1:A10, what's the best way to delete all images and left value whilst keeping all the values in C onwards to remain in the exact same place?

I only want to delete adjacent cell if an image is there so something like this but this really messes up the sheet lol.

Before macro

A1 Value B1 Image C1 1
A2 Value B2 Blank C2 2
A3 Value B3 Image C3 3
A4 Value B4 Blank C4 4

Finished result

A1 Value B1 Blank C1 1
A2 Value B2 Blank C2 2
A3 Blank B3 Blank C3 3
A4 Blank B4 Blank C4 4

Sub getLocation()

Dim wks As Worksheet

Set wks = Sheets("Sheet1")

For Each sshapes In wks.Shapes

x = sshapes.TopLeftCell.Row

wks.Cells(x, 2).Offset(0, -1).Delete

sshapes.Delete

Next

End Sub
 
Always test on backup copy.
Code:
Sub Ken2()
  Dim s As Shape, i As Long, j As Long, a
  Dim ws As Worksheet, wb As Workbook, r As Range
  
  Set ws = Sheets("Sheet1")
  For Each s In ws.Shapes
    If s.TopLeftCell.Column = 2 Then i = i + 1
  Next s

  If i = 0 Then Exit Sub
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
  
  ReDim a(1 To i, 1 To 2)
  
  i = 0
  For Each s In Sheets("Sheet1").Shapes
    If s.TopLeftCell.Column = 2 Then
      i = i + 1
      a(i, 1) = s.TopLeftCell.Row
      a(i, 2) = s.Name
    End If
  Next s
  j = i
    
  Set wb = Workbooks.Add
  Set r = Range("A1").Resize(UBound(a, 1), UBound(a, 2))
  r.Value = a
  wb.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A1"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
  With wb.Worksheets("Sheet1").Sort
    .SetRange r
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With
  a = r.Value
  wb.Close False
  
  For j = 1 To i
    ws.Shapes(a(j, 2)).Delete
    ws.Cells(a(j, 1), "A").Delete xlUp
  Next j
  
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic
End Sub

Perfect! thanks :D
 
Upvote 0

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
Always test on backup copy.
Code:
Sub Ken2()
  Dim s As Shape, i As Long, j As Long, a
  Dim ws As Worksheet, wb As Workbook, r As Range
  
  Set ws = Sheets("Sheet1")
  For Each s In ws.Shapes
    If s.TopLeftCell.Column = 2 Then i = i + 1
  Next s

  If i = 0 Then Exit Sub
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
  
  ReDim a(1 To i, 1 To 2)
  
  i = 0
  For Each s In Sheets("Sheet1").Shapes
    If s.TopLeftCell.Column = 2 Then
      i = i + 1
      a(i, 1) = s.TopLeftCell.Row
      a(i, 2) = s.Name
    End If
  Next s
  j = i
    
  Set wb = Workbooks.Add
  Set r = Range("A1").Resize(UBound(a, 1), UBound(a, 2))
  r.Value = a
  wb.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A1"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
  With wb.Worksheets("Sheet1").Sort
    .SetRange r
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With
  a = r.Value
  wb.Close False
  
  For j = 1 To i
    ws.Shapes(a(j, 2)).Delete
    ws.Cells(a(j, 1), "A").Delete xlUp
  Next j
  
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic
End Sub

I adjusted this to my needs, going from this code, I've now added another column inbetween A and B, so it's now name in A and image in C.
How can I adjust the following code to suit this?

Code:
Private Sub ClearImages()

  Dim s As Shape, i As Long, j As Long, a
  Dim ws As Worksheet, wb As Workbook, r As Range
  
  Set ws = Sheets("Pictures Not Found DIR")
  For Each s In ws.Shapes
    If s.TopLeftCell.Column = 2 Then i = i + 1
  Next s


  If i = 0 Then Exit Sub
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
  
  ReDim a(1 To i, 1 To 2)
  
  i = 0
  For Each s In Sheets("Pictures Not Found DIR").Shapes
    If s.TopLeftCell.Column = 2 Then
      i = i + 1
      a(i, 1) = s.TopLeftCell.Row
      a(i, 2) = s.Name
    End If
  Next s
  j = i
    
  Set wb = Workbooks.Add
  Set r = Range("A1").Resize(UBound(a, 1), UBound(a, 2))
  r.Value = a
  wb.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A1"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
  With wb.Worksheets("Sheet1").Sort
    .SetRange r
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With
  a = r.Value
  wb.Close False
  
  For j = 1 To i
    ws.Shapes(a(j, 2)).Delete
    ws.Cells(a(j, 1), "A").Delete xlUp
  Next j
  
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic
  
  Set ws = Nothing
  
End Sub
 
Upvote 0
maybe:
Code:
Sub ken3()
  Dim s As Shape, i As Long, j As Long, a
  Dim ws As Worksheet, wb As Workbook, r As Range
  
  Set ws = Sheets("Sheet1")
  For Each s In ws.Shapes
    If s.TopLeftCell.Column = 3 Then i = i + 1  '3=Column C
  Next s

  If i = 0 Then Exit Sub
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
  
  ReDim a(1 To i, 1 To 2)
  
  i = 0
  For Each s In Sheets("Sheet1").Shapes
    If s.TopLeftCell.Column = 3 Then      '3=Column "C"
      i = i + 1
      a(i, 1) = s.TopLeftCell.Row
      a(i, 2) = s.Name
    End If
  Next s
  j = i
    
  Set wb = Workbooks.Add
  Set r = Range("A1").Resize(UBound(a, 1), UBound(a, 2))
  r.Value = a
  wb.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A1"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
  With wb.Worksheets("Sheet1").Sort
    .SetRange r
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With
  a = r.Value
  wb.Close False
  
  For j = 1 To i
    ws.Shapes(a(j, 2)).Delete
    ws.Cells(a(j, 1), "A").Delete xlUp
  Next j
  
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic
End Sub
 
Upvote 0

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

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