VBA - floating photo

Olekkul

New Member
Joined
Aug 29, 2024
Messages
2
Office Version
  1. 365
Platform
  1. Windows
Hi I've been working on that code with GPT usage.
I tried to find the solution but any change to the code doesn't let me insert photo to a cell. The photo is floating on the sheet
VBA Code:
Sub SelectSheetAndPasteValue()
    Dim sheet As Worksheet
    Dim selectedSheet As String
    Dim employeeNumber As Long
    Dim lastRow As Long
    Dim insertRow As Long
    Dim i As Long
    Dim startingRow As Long
    Dim imagePath As String
    Dim picture As picture
    Dim numberFound As Boolean
    Dim newColumn As Long
    
    ' Set the starting row (data starts from row 5)
    startingRow = 5

    ' Prompt the user to enter the sheet name
    selectedSheet = Application.InputBox("Select the department name from the list next to it:", "Sheet Selection", Type:=2)

    ' Check if the sheet exists
    On Error Resume Next
    Set sheet = ThisWorkbook.Worksheets(selectedSheet)
    On Error GoTo 0

    If sheet Is Nothing Then
        MsgBox "The sheet named '" & selectedSheet & "' does not exist.", vbExclamation
        Exit Sub
    Else
        MsgBox "Selected sheet: " & selectedSheet
    End If
    
    ' Prompt the user to enter the employee number
    employeeNumber = Application.InputBox("Enter the employee number:", "Employee Number", Type:=1)
    
    ' Find the last row with data in column B from the starting row
    lastRow = sheet.Cells(sheet.Rows.Count, 2).End(xlUp).Row
    
    ' Ensure the last row is below the starting row
    If lastRow < startingRow Then
        lastRow = startingRow - 1
    End If
    
    ' Check if the employee number already exists
    numberFound = False
    For i = startingRow To lastRow
        If sheet.Cells(i, 2).Value = employeeNumber Then
            numberFound = True
            insertRow = i
            Exit For
        End If
    Next i
    
    ' If the employee number is found, copy column C to the new column D
    If numberFound Then
        newColumn = sheet.Cells(1, 3).Column + 1
        sheet.Columns(newColumn).Insert Shift:=xlToRight
        sheet.Columns(3).Copy
        sheet.Columns(newColumn).PasteSpecial Paste:=xlPasteFormats
        
        ' Prompt the user to select an image
        imagePath = Application.GetOpenFilename("Images (*.jpg; *.jpeg; *.png), *.jpg; *.jpeg; *.png", , "Select an image")
        
        If imagePath <> "False" Then
            ' Remove any existing images in this cell, if any
            For Each picture In sheet.Pictures
                If Not Intersect(picture.TopLeftCell, sheet.Cells(insertRow, newColumn)) Is Nothing Then
                    picture.Delete
                End If
            Next picture
            
            ' Insert the new image into the new column in the appropriate row
            Set picture = sheet.Pictures.Insert(imagePath)
            
            With picture
                ' Assign the position and size of the image to the cell
                .Top = sheet.Cells(insertRow, newColumn).Top
                .Left = sheet.Cells(insertRow, newColumn).Left
                .Width = sheet.Cells(insertRow, newColumn).Width
                .Height = sheet.Cells(insertRow, newColumn).Height
                .Placement = xlMoveAndSize ' Set the image to be tied to the cell
            End With
            
            ' Set the image to stay in the cell (optional)
            sheet.Shapes(sheet.Shapes.Count).Placement = xlMoveAndSize
        Else
            MsgBox "No image selected.", vbExclamation
        End If

    Else
        ' Find the place to insert the new number to maintain sorting
        For i = startingRow To lastRow
            If sheet.Cells(i, 2).Value > employeeNumber Then
                insertRow = i
                Exit For
            End If
        Next i
        
        ' If the new number is the largest, insert it at the end
        If insertRow = 0 Then
            insertRow = lastRow + 1
        End If
        
        ' Insert the new row
        sheet.Rows(insertRow).Insert Shift:=xlDown
        
        ' Insert the employee number into column B
        sheet.Cells(insertRow, 2).Value = employeeNumber
        
        ' Prompt the user to select an image
        imagePath = Application.GetOpenFilename("Images (*.jpg; *.jpeg; *.png), *.jpg; *.jpeg; *.png", , "Select an image")
        
        If imagePath <> "False" Then
            ' Insert the image into column C in the appropriate row
            Set picture = sheet.Pictures.Insert(imagePath)
            With picture
                .Top = sheet.Cells(insertRow, 3).Top
                .Left = sheet.Cells(insertRow, 3).Left
                .Width = sheet.Cells(insertRow, 3).Width
                .Height = sheet.Cells(insertRow, 3).Height
                .Placement = xlMoveAndSize ' Set the image to be tied to the cell
            End With
        Else
            MsgBox "No image selected.", vbExclamation
        End If
    End If
    
    MsgBox "Employee number and image have been inserted into the sheet " & selectedSheet & ".", vbInformation
End Sub
 

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
That is not the code to insert a picture into a cell. That would be:

VBA Code:
sheet.Cells(insertRow, newColumn).InsertPictureInCell imagePath
 
Upvote 0
If you could help me. What part of the code shoud I delete? Or how the proper code should look like?
 
Upvote 0
Replace these bits (both instances):

VBA Code:
        If imagePath <> "False" Then
            ' Remove any existing images in this cell, if any
            For Each picture In sheet.Pictures
                If Not Intersect(picture.TopLeftCell, sheet.Cells(insertRow, newColumn)) Is Nothing Then
                    picture.Delete
                End If
            Next picture
            
            ' Insert the new image into the new column in the appropriate row
            Set picture = sheet.Pictures.Insert(imagePath)
            
            With picture
                ' Assign the position and size of the image to the cell
                .Top = sheet.Cells(insertRow, newColumn).Top
                .Left = sheet.Cells(insertRow, newColumn).Left
                .Width = sheet.Cells(insertRow, newColumn).Width
                .Height = sheet.Cells(insertRow, newColumn).Height
                .Placement = xlMoveAndSize ' Set the image to be tied to the cell
            End With
            
            ' Set the image to stay in the cell (optional)
            sheet.Shapes(sheet.Shapes.Count).Placement = xlMoveAndSize
        Else
            MsgBox "No image selected.", vbExclamation
        End If

with this:

VBA Code:
        If imagePath <> "False" Then
            sheet.Cells(insertRow, newColumn).InsertPictureInCell imagePath
        Else
            MsgBox "No image selected.", vbExclamation
        End If
 
Upvote 0
Solution

Forum statistics

Threads
1,224,595
Messages
6,179,798
Members
452,943
Latest member
Newbie4296

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top