Сортировка фотографий

Question

Я скрывался некоторое время, но только что подписался, чтобы задать этот вопрос.Я очень новичок в кодировании, поэтому, пожалуйста, прости любые глупые ошибки.

Я пытаюсь выбрать изображения, которые находятся в случайных ячейках в столбце «K», и поместить их в строку 1, начиная с столбца «K».Я могу скопировать каждую картинку с помощью приведенного ниже кода.

Проблема начинается, когда я пытаюсь найти первую ячейку, начинающуюся со строки «K», которая не имеет формы.Я перебираю все картинки .TopLeftCell.Address и сравниваю их с текущими ячейками .Address для копирования.

Проблема в том, что я не могу понять, как начать другой цикл, чтобы проверить, работают ли ячейкине имеют формы в них, так как я уже использую цикл For Each picS In ActiveSheet.Shapes и не могу повторить его внутри собственного цикла.

Любая помощь приветствуется

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

вот как я это сделаю (пояснения в комментариях)

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

этот код не управляет регистром формы в первом столбце искомой строки: я оставлю это на ваше усмотрениедо

Answer 2

Если вам необходимо узнать, содержит ли какая-либо конкретная ячейка Shape, сначала создайте диапазон всех ячеек, которые "содержат" Shape с.Затем вы можете использовать Intersect(), чтобы увидеть, находится ли конкретная ячейка в этом диапазоне.

Чтобы получить диапазон контейнеров фигур:

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

, например:

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