Best Way To Delete All Shapes And Adjacent Cell?

[Lewzerrrr]

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

 

[Lewzerrrr]

Always test on backup copy.

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

 

[Lewzerrrr]

Always test on backup copy.

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?

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

 

[Kenneth Hobson]

maybe:

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