Forum Discussion
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
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
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