MS EXCEL VBA Code for Copy Image.

Hi Everyone! Here I have an Excel sheet with all models Images and want to get some spcifice models images to the new sheet and I have also the Image names and position (e.g Image name "948" and pos...

Book1.xlsm11 MB

developer

excel

Formulas and Functions

Oct 23, 2022

Here you go:

Sub CopyPictures()
    Dim r As Long
    Dim m As Long
    Dim shp As Shape
    Dim rng As Range
    Application.ScreenUpdating = False
    Sheet2.Select
    m = Sheet2.Range("D" & Sheet2.Rows.Count).End(xlUp).Row
    For Each shp In Sheet2.Shapes
        If Not Intersect(shp.TopLeftCell, Sheet2.Range("C2:C" & m)) Is Nothing Then
            shp.Delete
        End If
    Next shp
    For r = 2 To m
        Set rng = Sheet1.Range(Sheet2.Range("D" & r).Value)
        For Each shp In Sheet1.Shapes
            If Not Intersect(shp.TopLeftCell, rng) Is Nothing Then
                shp.Copy
                Sheet2.Range("C" & r).Select
                Sheet2.Paste
                Exit For
            End If
        Next shp
    Next r
    Application.ScreenUpdating = True
End Sub

Sub CopyPictures() Dim r As Long Dim m As Long Dim shp As Shape Dim rng As Range Application.ScreenUpdating = False Sheet2.Select m = Sheet2.Range("D" & Sheet2.Rows.Count).End(xlUp).Row For Each shp In Sheet2.Shapes If Not Intersect(shp.TopLeftCell, Sheet2.Range("C2:C" & m)) Is Nothing Then shp.Delete End If Next shp For r = 2 To m Set rng = Sheet1.Range(Sheet2.Range("D" & r).Value) For Each shp In Sheet1.Shapes If Not Intersect(shp.TopLeftCell, rng) Is Nothing Then shp.Copy Sheet2.Range("C" & r).Select Sheet2.Paste Exit For End If Next shp Next r Application.ScreenUpdating = True End Sub

Forum Discussion

MS EXCEL VBA Code for Copy Image.

Resources