在用户表单中插入图像并通过单击行更改“Teardrop 16”

Question

我想用Excel VBA编写一个用户表单。在我的表单中，我有两种形式：添加和搜索。

在添加表单中，我想添加名称、ID、部分...和图像。

我可以在用户表单中插入图像，在“l”中你可以看到文件路径。

我还将图像路径分配给“l1”，当我单击表格顶部的路径时，我的路径如图所示。

我想更改“Teardrop16”中的图片，当我单击一行时。

这是将表格的每一行分配给单元格的子程序：

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

Answer 1

• Range("l1" & ActiveCell.Row)

  错了。我认为 L 列中没有数据。我猜你尝试检查 I 列中的单元格。它应该是

  Range("I" & ActiveCell.Row)

  或

  Cells(ActiveCell.Row, "I")

  。
• 选择形状无需填充
• 代码可以重构如下。

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