VBA实现将单元格图片的复制到另一个工作表特定单元格中

6739912

VBA实现将单元格图片的复制到另一个工作表特定单元格中，请大神帮帮忙忙

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, br(), i&, j&, r&, Rng As Range, shp As Shape
   
    With [D2:E2]
        For j = 1 To Columns.Count
            Set Rng = .Cells(j)
            For Each shp In ActiveSheet.Shapes
                If shp.Type = 13 Then
                    If Abs((shp.Left + shp.Width / 2) - (Rng.Left + Rng.Width / 2)) < (shp.Width + Rng.Width) / 2 And _
                    Abs((shp.Top + shp.Height / 2) - (Rng.Top + Rng.Height / 2)) < (shp.Height + Rng.Height) / 2 Then
                        r = r + 1
                        ReDim Preserve br(1 To r)
                        br(r) = shp.Name
                    End If
                End If

            Next
        Next j
    End With
   
    If r Then
        ActiveSheet.Shapes.Range(br).Select
        Selection.Copy
        With Sheets(2)
            For Each shp In .Shapes
                shp.Delete
            Next
            .Activate
            .[K4].Select
            .Paste
        End With
    End If

    Beep
End Sub

gwjkkkkk

请参考附件。。。

6739912

老师、复制的图片自适应单元格如何写

gwjkkkkk

6739912 发表于 2024-1-17 15:05
老师、复制的图片自适应单元格如何写

简单修改一下。。。

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, br(), cr(), i&, j&, r&, Rng As Range, shp As Shape, m&, n&
   
    With [D2:E2]
        For j = 1 To Columns.Count
            Set Rng = .Cells(j)
            For Each shp In ActiveSheet.Shapes
                If shp.Type = 13 Then
                    If Abs((shp.Left + shp.Width / 2) - (Rng.Left + Rng.Width / 2)) < (shp.Width + Rng.Width) / 2 And _
                    Abs((shp.Top + shp.Height / 2) - (Rng.Top + Rng.Height / 2)) < (shp.Height + Rng.Height) / 2 Then
                        r = r + 1
                        If r = 1 Then
                            m = Rng.RowHeight: n = Rng.ColumnWidth
                        End If
                        ReDim Preserve br(1 To r)
                        br(r) = shp.Name
                        ReDim Preserve cr(1 To 2, 1 To r)
                        cr(1, r) = m: cr(2, r) = n
                    End If
                End If

            Next
        Next j
    End With
   
    If r Then
        ActiveSheet.Shapes.Range(br).Select
        Selection.Copy
        With Sheets(2)
            For Each shp In .Shapes
                shp.Delete
            Next
            .Activate
            .[K4].Select
            .Paste
            With .[K4]
                For j = 1 To UBound(cr)
                    With .Cells(1, j)
                        .RowHeight = cr(1, j)
                        .ColumnWidth = cr(2, j)
                    End With
                Next j
            End With
            
        End With
    End If

    Beep
End Sub