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