Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
With Target.Cells(1)
If (.Column = 3 Or .Column = 7) And .Row Mod 16 = 2 Then
addPic Target.Cells(1)
End If
End With
End Sub
Option Explicit
Sub fdjpg(nm As String)
With Application.FileSearch
.LookIn = ThisWorkbook.Path
.SearchSubFolders = True
.Filename = nm & ".jpg"
If .Execute <> 0 Then
nm = .FoundFiles(1)
Else
nm = ""
End If
End With
End Sub
Sub addPic(tgRng As Range)
Dim rng As Range
Dim nm As String
Dim shp As Shape
With tgRng
nm = .Text
Set rng = .Offset(0, -2).Resize(15, 1)
End With
fdjpg nm
If nm <> "" Then
rng.Worksheet.Pictures.Insert(nm).Select
With Selection
.Top = rng.Top
.Left = rng.Left
.Placement = xlMoveAndSize
.Width = rng.Width
.Height = rng.Height
End With
Else
MsgBox nm & " not found!"
End If
End Sub
問題以解決謝謝幫忙
修改如下:
Option Explicit
Sub fdjpg(nm As String)
With Application.FileSearch
.LookIn = ThisWorkbook.Path
.SearchSubFolders = True
.Filename = nm & ".jpg"
If .Execute <> 0 Then
nm = .FoundFiles(1)
Else
nm = ""
End If
End With
End Sub
Sub addPic(tgRng As Range)
Dim rng As Range
Dim nm As String
Dim shp As Shape
Dim picname As String
Dim pic As Shape
picname = tgRng.Row & tgRng.Column
With tgRng
nm = .Text
Set rng = .Offset(0, -2).Resize(15, 1)
End With
fdjpg nm
If nm <> "" Then
For Each pic In rng.Worksheet.Shapes
If pic.Name = picname Then pic.Delete
Next
Set shp = rng.Worksheet.Shapes.AddPicture(nm, msoFalse, msoTrue, rng.Left, rng.Top, rng.Width, rng.Height)
shp.Name = picname
Else
MsgBox nm & " 您可能填错了货号。"
End If
End Sub