Sorting Pictures

Question

I am trying to select pictures which are in random cells in column "K" and place them in row 1, starting at column "K". I am able to copy each picture with the below code.

I am trying to find the first cell starting at row "K" which doesn't have a shape in it. I am looping through all of the pictures .TopLeftCell.Address and comparing it with the current cells .Address to copy.

I can't figure out how to begin another loop to check if the cells do not have a shape in them, as I am already using the For Each picS In ActiveSheet.Shapes loop and can't loop it again inside its own loop.

Sub findPics()

    Dim picRng As Range
    Dim picS As Shape
    Dim picAdd As Range
    Dim lRow As Long

    For lRow = 2 To 30
        For Each picS In ActiveSheet.Shapes

            Set picAdd = Range(picS.TopLeftCell.Address)

            If ActiveSheet.Range("K" & lRow).Address =   picAdd.Address Then
                Debug.Print "Picture " & picS.ID; " in cell" &  ActiveSheet.Range("K" & lRow).Address
                Range(picAdd.Address).CopyPicture
                'Need to find first cell of row 1 without image in it starting at column "K"

            Else
                Debug.Print "Picture " & picS.ID; " isn't in" & ActiveSheet.Range("K" & lRow).Address
            End If

        Next picS           
    Next lRow

End Sub

Answer 1

If you need to know if any particular cell contains a Shape, first create a range of all cells that "contain" Shapes. Then you can useIntersect() to see if the particular cell is in that range.

To get the range of shape containers:

Public Function WhereAreShapes(sh As Worksheet) As Range
    Dim shp As Shape
    Set WhereAreShapes = Nothing
    If sh.Shapes.Count = 0 Then Exit Function

    For Each shp In sh.Shapes
        If WhereAreShapes Is Nothing Then
            Set WhereAreShapes = shp.TopLeftCell
        Else
            Set WhereAreShapes = Union(WhereAreShapes, shp.TopLeftCell)
        End If
    Next shp
End Function

for example:

Sub MAIN()
    Dim r As Range
    Set r = WhereAreShapes(Worksheets("Sheet1"))
    MsgBox r.Address
End Sub

Answer 2

here's how I'd do that (explanations in comments)

Option Explicit

Sub findPics()
    Dim shapesToMove() As Shape
    Dim iShp As Long

    shapesToMove = GetShapesInColumn(11) 'collect all shapes in column "K" (i.e. column index 11)
    If UBound(shapesToMove) = -1 Then Exit Sub 'if no shapes to move then do nothing

    Dim rangeToPlaceShapesIn As Range
    Set rangeToPlaceShapesIn = GetRangeWithNoShapesInRow(1, 11) ' get "free" cells to place shapes in row 1 starting from column "K" (i.e. column index 11)

    Dim cell As Range
    For Each cell In rangeToPlaceShapesIn ' loop through "free" cells
        iShp = iShp + 1 ' update current shape to consider
        shapesToMove(iShp).Top = cell.Top ' move current shape row to current "free" cell row
        shapesToMove(iShp).Left = cell.Left ' move current shape column to current "free" cell column
        If iShp = UBound(shapesToMove) Then Exit For ' exit upon having dealt with last shape to move
    Next
End Sub

Function GetShapesInColumn(columnIndex As Long) As Shape()
    Dim iShp As Long, shp As Shape

    With ActiveSheet
        ReDim myShapes(1 To .Shapes.Count) As Shape
        For Each shp In .Shapes
            If shp.TopLeftCell.Column = columnIndex Then
                iShp = iShp + 1
                Set myShapes(iShp) = shp
            End If
        Next
    End With
    If iShp > 0 Then
        ReDim Preserve myShapes(1 To iShp) As Shape
        GetShapesInColumn = myShapes
    End If
End Function

Function GetRangeWithNoShapesInRow(rowIndex As Long, columnToStartPlacingShapesFrom As Long) As Range
    Dim shp As Shape
    Dim shpRange As Range

    Set shpRange = Cells(rowIndex + 1, 1) ' set 'shpRange' to a "dummy" cell outside the wanted row
    For Each shp In ActiveSheet.Shapes ' loop through shapes
        If shp.TopLeftCell.Row = rowIndex Then If shp.TopLeftCell.Column >= columnToStartPlacingShapesFrom Then Set shpRange = Union(shpRange, shp.TopLeftCell) ' if current shape cell is in range where to place shapes in then collect that cell to "forbidden" range
    Next
    Set shpRange = Intersect(shpRange, Rows(rowIndex)) ' get rid of "dummy" cell

    If Not shpRange Is Nothing Then shpRange.EntireColumn.Hidden = True ' hide columns with "forbidden" range, if any
    Columns(1).Resize(, columnToStartPlacingShapesFrom - 1).EntireColumn.Hidden = True ' hide columns before first column to start placing shapes from

    Set GetRangeWithNoShapesInRow = Rows(rowIndex).SpecialCells(xlCellTypeVisible) ' set "free" range as the visible one in the wanted row
    Columns.EntireColumn.Hidden = False ' get cells visible back
End Function

this code doesn't manage the case of a shape in first column of wanted row: I'll leave it up to you to