图片排序

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

如果您需要知道是否有任何特定的单元格包含Shape，请首先创建一个范围为 all 的单元格，这些单元格包含“ 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

Answer 2

这是我的处理方式（注释中的解释）

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

此代码无法管理通缉行第一栏中形状的情况：我将由您自己决定