forerver
06-16-2019, 02:20 AM
Hi
I need small help.
I get this code from this forum. i need something to add the code for offset in the 2 column only. like this sample.
24399
only 2 columns (A and B). after I enter the name in Column C3 & D3 automatic return in C4 after I press the enter.
here the code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count <> "1" Or Target.Column <> 1 Or Target.Value = "" Then Exit Sub
Dim wbpath As String
Dim photoPath As String
Dim wB As Workbook
Dim wS As Worksheet
Dim photoName As String
Dim photoFile As String
Dim Cell As Range
Dim rng As Range
Dim sh As Shape
Dim noPhoto As String
noPhoto = "NOPHOTO.jpg"
Dim photoExt As String
photoExt = ".jpg"
'Turn screen updating off. You won't see the client file being updated.
Application.ScreenUpdating = False
Set wB = ActiveWorkbook
Set wS = wB.Worksheets("Sheet1")
' path to your folder
wbpath = "G:\sample"
' the path to the folder witl aal the photos
photoPath = "G:\sample\"
Set Cell = Target
If Not Cell.Column = 1 Or Len(Trim(Cell.Value)) = 0 Then Exit Sub
photoName = Cell.Value
Set rng = wS.Range("E" & Cell.Row)
photoFile = photoName & photoExt
GoSub placePhotoInSheet
Err.Clear
On Error GoTo 0
Application.ScreenUpdating = True
Exit Sub
deleteAllShapes:
For Each sh In wS.Shapes
sh.Delete
Next sh
Return
placePhotoInSheet:
On Error Resume Next
wS.Shapes(photoName).Select
If Err.Number = 1 Then
wS.Shapes(photoName).Visible = msoTrue
Return
End If
GoSub deleteAllShapes
rng.Select
If Not Dir(photoPath & photoFile) = "" Then
ActiveSheet.Pictures.Insert(photoPath & photoFile).Select
ElseIf Not Dir(wbpath & noPhoto) = "" Then
ActiveSheet.Pictures.Insert(wbpath & noPhoto).Select
ElseIf Not Dir(photoPath & noPhoto) = "" Then
ActiveSheet.Pictures.Insert(photoPath & noPhoto).Select
Else
Return
End If
With Selection.ShapeRange
.Name = photoName
.LockAspectRatio = msoTrue
.Top = rng.Top
.Left = rng.Left
'.Width = 141.75
.Height = 141.75
.IncrementLeft 0.75
.IncrementTop -130
End With
rng.Offset(1, -rng.Column + 1).Select
Return
End Sub
I need small help.
I get this code from this forum. i need something to add the code for offset in the 2 column only. like this sample.
24399
only 2 columns (A and B). after I enter the name in Column C3 & D3 automatic return in C4 after I press the enter.
here the code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count <> "1" Or Target.Column <> 1 Or Target.Value = "" Then Exit Sub
Dim wbpath As String
Dim photoPath As String
Dim wB As Workbook
Dim wS As Worksheet
Dim photoName As String
Dim photoFile As String
Dim Cell As Range
Dim rng As Range
Dim sh As Shape
Dim noPhoto As String
noPhoto = "NOPHOTO.jpg"
Dim photoExt As String
photoExt = ".jpg"
'Turn screen updating off. You won't see the client file being updated.
Application.ScreenUpdating = False
Set wB = ActiveWorkbook
Set wS = wB.Worksheets("Sheet1")
' path to your folder
wbpath = "G:\sample"
' the path to the folder witl aal the photos
photoPath = "G:\sample\"
Set Cell = Target
If Not Cell.Column = 1 Or Len(Trim(Cell.Value)) = 0 Then Exit Sub
photoName = Cell.Value
Set rng = wS.Range("E" & Cell.Row)
photoFile = photoName & photoExt
GoSub placePhotoInSheet
Err.Clear
On Error GoTo 0
Application.ScreenUpdating = True
Exit Sub
deleteAllShapes:
For Each sh In wS.Shapes
sh.Delete
Next sh
Return
placePhotoInSheet:
On Error Resume Next
wS.Shapes(photoName).Select
If Err.Number = 1 Then
wS.Shapes(photoName).Visible = msoTrue
Return
End If
GoSub deleteAllShapes
rng.Select
If Not Dir(photoPath & photoFile) = "" Then
ActiveSheet.Pictures.Insert(photoPath & photoFile).Select
ElseIf Not Dir(wbpath & noPhoto) = "" Then
ActiveSheet.Pictures.Insert(wbpath & noPhoto).Select
ElseIf Not Dir(photoPath & noPhoto) = "" Then
ActiveSheet.Pictures.Insert(photoPath & noPhoto).Select
Else
Return
End If
With Selection.ShapeRange
.Name = photoName
.LockAspectRatio = msoTrue
.Top = rng.Top
.Left = rng.Left
'.Width = 141.75
.Height = 141.75
.IncrementLeft 0.75
.IncrementTop -130
End With
rng.Offset(1, -rng.Column + 1).Select
Return
End Sub