Opening multiple excel file from a folder and pasting image in two sheets

[AmitSingh]

Hi All,

Need help in opening multiple excel file 1 by 1 and pasting the image in two sheets named "MCU" and "Summary" in a cell. I am able to open first excel file and able to paste it the image in two sheets but not able to do it in others excel file present in folders. There may a many as excel file in a folder.
Please find below code which I have tried.
Any help is appreciated as this little urgent. Thanks in advance.

Below is main code for opening multiple excel file

Sub FileImageCopy()

Dim i As Integer
Dim j As Integer
Dim Fname As Variant
Dim Path As Variant
Dim Imagename As Variant
Dim wbk, wbk1 As Workbook
Dim ws As Worksheet
Dim sh As Shape
Dim p As Object
Dim a As Single
Dim Ha As Object
Dim Wa As Object

Path = "C:\Users\611892636\desktop\Paste Pic\" 'change according to your location
If Right(Path, 1) <> "\" Then Path = Path + "\"
Fname = Dir(Path & "*.xlsm")

Do While Fname <> ""
Application.ScreenUpdating = False
Set wbk = Workbooks.Open(Path & Fname)

Call PasteImage 'calling method for paasting the image in excel files to two sheets

Fname = Dir
Loop
Application.ScreenUpdating = True

End Sub

Below code is PasteImage method.

Sub PasteImage()
Dim i As Integer
Dim j As Integer
Dim Imagename As Variant
Dim Fpath As Variant
Dim wbk As Workbook
Dim ws As Worksheet
Dim sh As Shape
Dim p As Object
Dim a As Single
Dim Ha As Object
Dim Wa As Object

Fpath = "C:\Users\611892636\desktop\Paste Pic\" 'change according to your location
If Right(Fpath, 1) <> "\" Then Fpath = Fpath + "\"
Imagename = Dir(Fpath & "*.jpg")

On Error Resume Next
For Each sh In ActiveSheet.Shapes
If sh.Type = 13 Or sh.Type = 7 Then
Call sh.Delete
End If
Next

'Open MCU sheet to paste BT Logo
wbk.Worksheets("MCU").Activate
Range("F50").Select
Set p = ActiveSheet.Pictures.insert(Imagename)
p.ShapeRange.LockAspectRatio = msoTrue 'Width and Height are in points (1/72 inch)
Ha = 3 / (p.Height / 72)
Wa = 5 / (p.Width / 72)
If Ha < Wa Then
a = Ha
Else
a = Wa
End If
p.Width = p.Width * a
p.Height = p.Height * a

'Open Summary sheet to paste BT Logo
wbk.Worksheets("Summry").Activate
Range("W1").Select
Set p = ActiveSheet.Pictures.insert(Imagename)
p.ShapeRange.LockAspectRatio = msoTrue 'Width and Height are in points (1/72 inch)
Ha = 3 / (p.Height / 72)
Wa = 5 / (p.Width / 72)
If Ha < Wa Then
a = Ha
Else
a = Wa
End If
p.Width = p.Width * a
p.Height = p.Height * a

wbk.Save
wbk.Close

End Sub

 

[Chihiro]

Please use Code tag <> for your code. I've edited it this time.

You don't have enough info for me to pinpoint your issue. You should post both workbooks (the file with code and sample workbook where images are pasted, along with what final outcome should look like). But here's some suggestions.

1. Make sure that your file containing the code resides outside the "C:\Users\611892636\desktop\Paste Pic\" folder.

2. Avoid use of Activesheet & Select. These aren't needed in code. Instead, add argument to PasteImage sub like below, and use that to set your wbk variable.

Sub PasteImage(wb as Workbook)

You'd then call PasteImage as...

Call PasteImage(wbk)

And instead of using ActiveSheet... set it to specific sheet...
Ex:

Set ws = wb.Worksheets("MCU")

 

[AmitSingh]

Sorry for the inconvenience you faced and thank you for reviewing my concern, I have attached the Sample workbook named "Sample File_Pictures.xlsm" and Zip file of excel workbooks named "Paste Pic.zip", in which the image has to be pasted. I have also attached the another workbook named "Pictures.xlsm" in which the code is written. There is no count of excel file in folder to paste the image, it can be as many as.

Thanks in advance

Warm Regards,
Amit Singh

 

[Chihiro]

I'd do it like below.

Since, you didn't specify shape location. It's left at top left of sheet. Adjust 1, 1 part of below as needed.

                Set p = .Shapes.AddPicture(Imagename, False, True, 1, 1, -1, -1)

Full code:

Option Explicit

Sub PasteImage()
Dim Fpath As String, Imagename As String, Fname As String
Dim sh As Shape, ws As Worksheet, wb As Workbook
Dim p, a
Fpath = ThisWorkbook.path & "\Paste Pic"              'change according to your location
If Right(Fpath, 1) <> "\" Then Fpath = Fpath & "\"
Imagename = Fpath & Dir(Fpath & "*.jpg")

Application.ScreenUpdating = False
Fname = Dir(Fpath & "*.xlsm")

Do While Fname <> ""
    Set wb = Workbooks.Open(Fpath & Fname)
    For Each ws In wb.Worksheets
        For Each sh In ws.Shapes
            If sh.Type = 13 Or sh.Type = 7 Or sh.Type = 11 Then
              sh.Delete
            End If
        Next
    Next
    For Each ws In wb.Worksheets
        If ws.Name = "MCU" Or ws.Name = "Summry" Then
            With ws
                Set p = .Shapes.AddPicture(Imagename, False, True, 1, 1, -1, -1)
                With p
                    .LockAspectRatio = msoTrue
                    a = IIf((3 / (.Height / 72)) < (5 / (.Width / 72)), 3 / (.Height / 72), 5 / (.Width / 72))
                    .Width = .Width * a
                    .Height = .Height * a
                End With
            End With
        End If
    Next
    wb.Close True
    Fname = Dir()
Loop
Application.ScreenUpdating = True
MsgBox "Process complete"
End Sub

NOTE: Workbook with the code should sit one level above xlsm & image file folder. See attached zip.

 

[AmitSingh]

Thank you sir, it really help a lot and it works. Thank you.

 

[AmitSingh]

One more thing I want to ask one thing that if I want to paste the image D1 in MCU Sheet and W1 in Summary, then where I should change as per above code

Set p = .Shapes.AddPicture(Imagename, False, True, 1, 1, -1, -1)

.
Kindly help me or advice where I have to change.

 

[Chihiro]

See link.
https://msdn.microsoft.com/en-us/vba/excel-vba/articles/shapes-addpicture-method-excel

So in this case, you don't need to define Top position, since both will be at very top of sheet (first row). However, if you wanted to define both...

I'd do it like below.

            Dim lPt As Long, tPt As Long
            With ws
                lPt = IIf(ws.Name = "MCU", ws.[D1].Left, ws.[W1].Left)
                tPt = IIf(ws.Name = "MCU", ws.[D1].Top, ws.[W1].Top)
                Set p = .Shapes.AddPicture(Imagename, False, True, lPt, tPt, -1, -1)

 

[AmitSingh]

Thank you again.