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

 

 

 

 

developer
excel
Formulas and Functions
Macros and VBA
office 365
  • HansVogelaar's avatar
    HansVogelaar
    Oct 23, 2022

    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

  • HansVogelaar's avatar
    HansVogelaar
    MVP
    Oct 23, 2022

    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