Search code examples
excelvbauserform

Inserting images in userform and change "Teardrop 16" by clicking on rows

I want to write a user-form by Excel VBA. In my from, I have two forms: add and search.

In the add form I want to add name, IDs, section,... and images.

I can insert an image in the user-form and in "l" you can see the file path.

I also assign the image-paths to "l1", when I click on the path in the top of my table my path as shown.

I want to change the picture in "Teardrop16", when I click on a row.

enter image description here

This is the sub for assigning each row of my table to a cell:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Sheet1.Range("A1").Value = Cells(Target.Row, 3).Value
'Sheet1.Range("B1").Value = Cells(Target.Row, 9).Value
Sheet1.Range("C1").Value = Cells(Target.Row, 4).Value
Sheet1.Range("I1").Value = Cells(Target.Row, 9).Value
'ow for the changing the image :

Dim perRange As String
perRange = ActiveCell.Address
Application.ScreenUpdating = False

If ActiveSheet.Range("l1" & ActiveCell.Row).Value = "" Then
err:
    ActiveSheet.Shapes.Range(Array("Teardrop 16")).Select
    With Selection.ShapeRange.Fill
        .UserPicture "C:\Users\niloofar sabouri\OneDrive\Desktop\pic\null.jpg"
        Range(perRange).Select
    End With
Exit Sub
End If

Dim iRow As Long
iRow = Sheet1.Cells(Rows.Count, "E").End(xlUp).Row
If Not Intersect(Target, Range("C4:" & "l1" & iRow)) Is Nothing Then

    ActiveSheet.Shapes.Range(Array("Teardrop 16")).Select
    With Selection.ShapeRange.Fill
        On Error GoTo err
        .UserPicture ActiveSheet.Range("l1" & ActiveCell.Row)
        Range(perRange).Select
    End With
End If

End Sub
Solution
    • Range("l1" & ActiveCell.Row) is wrong. I don't think there is data in column L. I guess you try to check the cell in column I. It should be Range("I" & ActiveCell.Row) or Cells(ActiveCell.Row, "I").
    • Select the shape is not necessary to fill it
    • The code could be refactored as below.
    Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim iRow As Long, sValue, sPic As String
    iRow = Me.Cells(Me.Rows.Count, "E").End(xlUp).Row
    If Not Intersect(Target, Me.Range("C4:I" & iRow)) Is Nothing Then
        sPic = Me.Cells(Target.Row, "I").Value
        If Len(sPic) = 0 Then
            sPic = "C:\Users\niloofar sabouri\OneDrive\Desktop\pic\null.jpg"
        End If
        Me.Shapes("Teardrop 16").Fill.UserPicture sPic
    End If
End Sub