Copy all objects in a column over as individual "Picture (Enhanced Metafile)" pics?

[Bret1]

Is there a way to copy all picture objects in a specific column over to another column as INDIVIDUAL "Picture (Enhanced Metafile)" pics?

I found this code that selects all objects in a column if it helps...

Sub SelectShape()
Dim shp As Shape
Dim r As Range


Set r = Columns("a:c")


For Each shp In ActiveSheet.Shapes
    If Not Intersect(Range(shp.TopLeftCell, shp.BottomRightCell), r) Is Nothing Then _
        shp.Select Replace:=False
Next shp
End Sub

 

[Domenic]

The following macro will loop through each shape in the active worksheet. It checks whether the shape is located in the specified source column, and then checks whether the shape is a picture. If so, it copies the picture to corresponding row in the specified destination column.

Option Explicit

Sub CopyPictures()


    Dim sourceColumn As Range
    Dim destinationColumn As Range
    Dim currentShape As Shape
    Dim originalSelection As Object
    
    If TypeName(ActiveSheet) <> "Worksheet" Then
        MsgBox "Worksheet is unavailable!", vbExclamation
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    Set originalSelection = Selection
    
    Set sourceColumn = Columns("A")
    Set destinationColumn = Columns("D")
    
    For Each currentShape In ActiveSheet.Shapes
        If Not Intersect(currentShape.TopLeftCell, sourceColumn) Is Nothing Then
            If currentShape.Type = msoPicture Then
                currentShape.Copy
                ActiveSheet.PasteSpecial _
                    Format:="Picture (Enhanced Metafile)", _
                    Link:=False, _
                    DisplayAsIcon:=False
                With ActiveSheet
                    With .Shapes(.Shapes.Count)
                        .Left = destinationColumn.Left
                        .Top = currentShape.Top
                    End With
                End With
            End If
        End If
    Next currentShape
    
    originalSelection.Select
    
    Application.ScreenUpdating = True
    
    MsgBox "Completed!", vbExclamation
      
End Sub

Hope this helps!

 

[Bret1]

Domenic, thank you very much for this! It works great!

 

[Bret1]

Domenic,
Thanks again for this wonderful code. It's working great!
I'm hoping you can help me with just a small change/addition to it....
Is it possible to remove the "Completed" action box and just allow it to complete the task and finish, then run another Macro after completing this one?
Below is what I previously had for running the next Macro...

 Application.ScreenUpdating = True
Application.Run "MoveDate"
End Sub

Thank you!

 

[Domenic]

Oh, yes, most definitely. Try...

Option Explicit

Sub CopyPictures()

    'etc
    '
    '

    For Each currentShape In ActiveSheet.Shapes
        'etc
        '
        '
        End If
    Next currentShape
    
    originalSelection.Select
    
    Application.Run "MoveDate"
    
    Application.ScreenUpdating = True
      
End Sub

 

[Bret1]

Domenic.
That worked GREAT! Thanks again!