Forum Discussion

KAM_Mumin's avatar
KAM_Mumin
Brass Contributor
Oct 23, 2022
Solved

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 position at "C2" in the main sheet). I make the below VBA code with the position for geting the images but this is for one row,,,

Please can any of you help me to get all the models images at a same time in the new sheet from the main sheet by edit the vba code. I attached below an excel file for understanding,,

 

 

 

Sub CopyPictures()
'
' CopyPictures Macro
'

'
    
    'If Range("shyT[@Model No]").Value = Range("All_Tiles[@Model No]").Value Then
    
    Dim shp As Shape
    Dim r As Range
    Sheet1.Select
    Set r = Range(Sheet2.Range("D5").Value)

    For Each shp In Sheet1.Shapes
        If Not Intersect(Range(shp.TopLeftCell, shp.BottomRightCell), r) Is Nothing Then _
            shp.Select Replace:=False
    Next shp
    
    'End If
    
    Selection.Copy
    Sheet2.Select
    Range("C2").Select
    ActiveSheet.Paste
    
End Sub

 

 

 

 

  • KAM_Mumin 

    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

1 Reply

  • KAM_Mumin 

    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

Resources