How to insert and offset an image based on cell value

Question

I'm facing a bit of an issue.

We needed to make a small, single cell, change to about a 1000 client statements (excel). I ran the change in python using openpyxl and all the company logos disappeared.

I have compiled a VBA to put the images back but am struggling with getting them in the right position on the second page as the top of the second page is not a set row number.

However, the clients name marks the top of the second page.

Is there a way I can search column B for the clients name and insert the companies logo in the same row but 9 columns to the right.

This is what I have so far:

Sub Example()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String, Fnum As Long
Dim mybook As Workbook
Dim CalcMode As Long
Dim sh As Worksheet
Dim ErrorYes As Boolean

'Fill in the path\folder where the files are
MyPath = "Path\to\excels"

'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
    MyPath = MyPath & "\"
End If

'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
    MsgBox "No files found"
    Exit Sub
End If

'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
    Fnum = Fnum + 1
    ReDim Preserve MyFiles(1 To Fnum)
    MyFiles(Fnum) = FilesInPath
    FilesInPath = Dir()
Loop

'Change ScreenUpdating, Calculation and EnableEvents
With Application
    CalcMode = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
End With

'Loop through all files in the array(myFiles)
If Fnum > 0 Then
    For Fnum = LBound(MyFiles) To UBound(MyFiles)
        Set mybook = Nothing
        On Error Resume Next
        Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
        On Error GoTo 0

        If Not mybook Is Nothing Then


            'Change cell value(s) in one worksheet in mybook
            On Error Resume Next
            With mybook.ActiveSheet.Pictures.Insert("C:Path\to\Pic.jpg")

                    With .ShapeRange
                        .LockAspectRatio = msoTrue
                        .Width = 40
                        .Height = 55
            End With
                        .Left = ActiveSheet.Range("K1").Left
                        .Top = ActiveSheet.Range("K1").Top
                        .Placement = 1
                        .PrintObject = True


            End With

            With ActiveSheet.Range("B12:L13").BorderAround(ColorIndex:=xlAutomatic, Weight:=xlMedium)

            End With

            If Err.Number > 0 Then
                ErrorYes = True
                Err.Clear
                'Close mybook without saving
                mybook.Close savechanges:=False
            Else
                'Save and close mybook
                mybook.Close savechanges:=True
            End If
            On Error GoTo 0
        Else
            'Not possible to open the workbook
            ErrorYes = True
        End If

    Next Fnum
End If

If ErrorYes = True Then
    MsgBox "There are problems in one or more files, possible problem:" _
         & vbNewLine & "protected workbook/sheet or a sheet/range that not exist"
End If

'Restore ScreenUpdating, Calculation and EnableEvents
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = CalcMode
End With

End Sub

What efforts have you made yourself? You should be able to google and cobble something together to kick you off. — SJR, Jan 23 '19 at 12:03
Have a look here. This should get you started. https://stackoverflow.com/questions/22542834/how-to-use-regular-expressions-regex-in-microsoft-excel-both-in-cell-and-loops — Jelmer, Jan 23 '19 at 12:03

score 0 · Answer 1 · answered Jan 23 '19 at 12:39

You could use:

Option Explicit

Sub image()

    Dim i As Long, Lastrow As Long
    Dim pic As Picture
    Dim rng As Range

    With ThisWorkbook.Worksheets("Sheet1")

        Lastrow = .Cells(.Rows.Count, "O").End(xlUp).Row

        For i = 1 To Lastrow

            If .Range("O" & i).Value = "Import" Then

                Set rng = .Range("O" & i).Offset(0, -9)

                With .Pictures.Insert("C:\Users\XXXXX\Desktop\download.jpg")
                    .Top = rng.Top
                    .Left = rng.Left
                End With

            End If

        Next i

    End With

End Sub

How to insert and offset an image based on cell value

1 Answers1