Batch replace image(s) in multiple files and sheets

[Polanskiman]

Hello Everyone,

First, I haven't found my answer in other threads, so if it does exist, please redirect me.

Now, here is my problem. I have thousands of excel files each containing a varying quantity of sheets. There are two logos in each file first sheet (at the same position) and these logos, in some instances, are also located on other sheets of each file. Each logo in the other sheets are located each time at the same position but in different position than in the first Sheet. Each logo is the same in all files and sheets.

What I need is to replace these 2 logos in all files/sheets with new ones. Doing this manually would literally take weeks even months full time.

Could anyone help me with this?

Thanks in advance.

 

[Polanskiman]

Anyone?

 

[Case_Germany]

Hi,

the easiest way - pack a few files plus the new logo in a zip file and upload it to a webhoster (look here). Then we'll see...

 

[Polanskiman]

Hello and thanks for the answer.

Not sure I understand, would you mind elaborating why I would need to upload the files and logos to a webhoster?

Hi,

the easiest way - pack a few files plus the new logo in a zip file and upload it to a webhoster (look here). Then we'll see...

 

[Case_Germany]

Hi,

only a few files, I'll write the code and there are not so many requests.

 

[Polanskiman]

I see. That is very kind. I have a website so I will upload the files and logos in the server and send you the link, but first I have to clean the files as they are confidential.

I'll get back to you soon.

And thanks.

Hi,

only a few files, I'll write the code and there are not so many requests.

 

[Polanskiman]

Hello,

Please find below the link containing sample excel files and sample replacement logos.

http://paullefevre.com/download/

Hope you can figure it out.

As a side note, there are thousands of those excel files so would it be possible to run some code without needing to open each file to make the change?

Thanks in advance.

Hi,

only a few files, I'll write the code and there are not so many requests.

 

[Case_Germany]

Hi,

I think the following should work (please test it on a few test files and try my test files - see below):

Option Explicit
Public Sub Main()
    Dim stCalc As Integer
    Dim strPath As String
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .AskToUpdateLinks = False
        .EnableEvents = False
        stCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' File is in the same directory as the file with the logos
    strPath = ThisWorkbook.Path & Application.PathSeparator
    ' File is in certain directory
    ' strPath = "C:\Temp\" ' adapt
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    ' SearchFiles strPath, "*.xls*", False ' without subfolder
    SearchFiles strPath, "*.xls*", True ' with subfolder
Fin:
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = stCalc
        .DisplayAlerts = True
    End With
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Private Sub SearchFiles(strFolder As String, strFileName As String, _
    Optional blnTMP As Boolean = False)
    Dim wksSheet As Worksheet
    Dim objFolder As Object
    Dim sngHeight As Single
    Dim sngWidth As Single
    Dim strLogo1 As String
    Dim strLogo2 As String
    Dim sngLeft As Single
    Dim shpShape As Shape
    Dim objFile As Object
    Dim sngTop As Single
    Dim objFSO As Object
    strLogo1 = ThisWorkbook.Path & Application.PathSeparator & "NEW_LOGO_1.jpg"
    strLogo2 = ThisWorkbook.Path & Application.PathSeparator & "NEW_LOGO_2.jpg"
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    For Each objFile In objFSO.GetFolder(strFolder).Files
        If objFile.Name Like strFileName And objFile.Name <> _
            ThisWorkbook.Name And Left(objFile.Name, 1) <> "~" Then
            Workbooks.Open objFile.Path
            For Each wksSheet In Workbooks(objFile.Name).Worksheets
                For Each shpShape In wksSheet.Shapes
                    With shpShape
                        If .TopLeftCell.Row > 4 Then
                            If .TopLeftCell.Row > 37 Then
                                sngHeight = .Height
                                sngWidth = .Width
                                sngTop = .Top
                                sngLeft = .Left
                                .Delete
                                wksSheet.Shapes.AddPicture(strLogo2, _
                                    True, True, sngLeft, sngTop, _
                                    sngWidth, sngHeight).Name = "Logo2"
                            Else
                                sngHeight = .Height
                                sngWidth = .Width
                                sngTop = .Top
                                sngLeft = .Left
                                .Delete
                                wksSheet.Shapes.AddPicture(strLogo1, _
                                    True, True, sngLeft, sngTop, _
                                    sngWidth, sngHeight).Name = "Logo1"
                            End If
                        ElseIf .TopLeftCell.Row < 4 Then
                            If .TopLeftCell.Column < 4 Then
                                sngHeight = .Height
                                sngWidth = .Width
                                sngTop = .Top
                                sngLeft = .Left
                                .Delete
                                wksSheet.Shapes.AddPicture(strLogo2, _
                                    True, True, sngLeft, sngTop, _
                                    sngWidth, sngHeight).Name = "Logo2"
                            Else
                                sngHeight = .Height
                                sngWidth = .Width
                                sngTop = .Top
                                sngLeft = .Left
                                .Delete
                                wksSheet.Shapes.AddPicture(strLogo1, _
                                    True, True, sngLeft, sngTop, _
                                    sngWidth, sngHeight).Name = "Logo1"
                            End If
                        End If
                    End With
                Next shpShape
            Next wksSheet
            Workbooks(objFile.Name).Close True
        End If
    Next objFile
    If blnTMP = True Then
        For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
            If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
            SearchFiles strFolder & "\" & objFolder.Name, strFileName, blnTMP
        Next objFolder
    End If
End Sub

It is evaluated both the size and position of the old logo and used for the new logo.

And here is an example: Try...

 

[Polanskiman]

Nicely done!! It works like a charm with the sample files.

However, when I use the code with my files I get an error: "Error: 70 Permission denied". It actually changed the Logo 2 in the COVER sheet but not in the other sheets.

Any clue why this is happening?

Thanks a lot for the time and work.

Hi,

I think the following should work (please test it on a few test files and try my test files - see below):

Option Explicit
Public Sub Main()
    Dim stCalc As Integer
    Dim strPath As String
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .AskToUpdateLinks = False
        .EnableEvents = False
        stCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' File is in the same directory as the file with the logos
    strPath = ThisWorkbook.Path & Application.PathSeparator
    ' File is in certain directory
    ' strPath = "C:\Temp\" ' adapt
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    ' SearchFiles strPath, "*.xls*", False ' without subfolder
    SearchFiles strPath, "*.xls*", True ' with subfolder
Fin:
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = stCalc
        .DisplayAlerts = True
    End With
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Private Sub SearchFiles(strFolder As String, strFileName As String, _
    Optional blnTMP As Boolean = False)
    Dim wksSheet As Worksheet
    Dim objFolder As Object
    Dim sngHeight As Single
    Dim sngWidth As Single
    Dim strLogo1 As String
    Dim strLogo2 As String
    Dim sngLeft As Single
    Dim shpShape As Shape
    Dim objFile As Object
    Dim sngTop As Single
    Dim objFSO As Object
    strLogo1 = ThisWorkbook.Path & Application.PathSeparator & "NEW_LOGO_1.jpg"
    strLogo2 = ThisWorkbook.Path & Application.PathSeparator & "NEW_LOGO_2.jpg"
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    For Each objFile In objFSO.GetFolder(strFolder).Files
        If objFile.Name Like strFileName And objFile.Name <> _
            ThisWorkbook.Name And Left(objFile.Name, 1) <> "~" Then
            Workbooks.Open objFile.Path
            For Each wksSheet In Workbooks(objFile.Name).Worksheets
                For Each shpShape In wksSheet.Shapes
                    With shpShape
                        If .TopLeftCell.Row > 4 Then
                            If .TopLeftCell.Row > 37 Then
                                sngHeight = .Height
                                sngWidth = .Width
                                sngTop = .Top
                                sngLeft = .Left
                                .Delete
                                wksSheet.Shapes.AddPicture(strLogo2, _
                                    True, True, sngLeft, sngTop, _
                                    sngWidth, sngHeight).Name = "Logo2"
                            Else
                                sngHeight = .Height
                                sngWidth = .Width
                                sngTop = .Top
                                sngLeft = .Left
                                .Delete
                                wksSheet.Shapes.AddPicture(strLogo1, _
                                    True, True, sngLeft, sngTop, _
                                    sngWidth, sngHeight).Name = "Logo1"
                            End If
                        ElseIf .TopLeftCell.Row < 4 Then
                            If .TopLeftCell.Column < 4 Then
                                sngHeight = .Height
                                sngWidth = .Width
                                sngTop = .Top
                                sngLeft = .Left
                                .Delete
                                wksSheet.Shapes.AddPicture(strLogo2, _
                                    True, True, sngLeft, sngTop, _
                                    sngWidth, sngHeight).Name = "Logo2"
                            Else
                                sngHeight = .Height
                                sngWidth = .Width
                                sngTop = .Top
                                sngLeft = .Left
                                .Delete
                                wksSheet.Shapes.AddPicture(strLogo1, _
                                    True, True, sngLeft, sngTop, _
                                    sngWidth, sngHeight).Name = "Logo1"
                            End If
                        End If
                    End With
                Next shpShape
            Next wksSheet
            Workbooks(objFile.Name).Close True
        End If
    Next objFile
    If blnTMP = True Then
        For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
            If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
            SearchFiles strFolder & "\" & objFolder.Name, strFileName, blnTMP
        Next objFolder
    End If
End Sub

It is evaluated both the size and position of the old logo and used for the new logo.

 

[Polanskiman]

[UPDATE] I have to apologize, the problem seems to come from the Excel version I was using (Excel 2003). I tried running the code with Excel 2010 and it worked perfectly!!! You are a genius!

On a side note, and this is just because I am a perfectionist, is there a way through the code to keep the new logos real proportions?