排序图片

Question

我潜伏了一段时间，但刚注册来问这个问题。我对编码很陌生，所以请原谅任何愚蠢的错误。

我正在尝试 select 列 "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，首先创建所有个单元格的范围 "contain" 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

此代码无法管理所需行第一列中形状的大小写：我会留给你

排序图片

Sorting Pictures

excel

vba

image

shapes