PDA

View Full Version : Move to right column after return when I press enter



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

Leith Ross
06-16-2019, 01:02 PM
Hello forever,

Here is the basic code to do this. Adapt it your your needs.



Private Sub Worksheet_Change(ByVal Target As Range)


If Target.Cells.Count > 1 Then Exit Sub

If Target.Column = 2 Then
Application.EnableEvents = False
Cells(Target.Row + 1, "A").Select
Application.EnableEvents = True
End If

End Sub

forerver
06-17-2019, 07:08 AM
thanks Leith,

Anyway, I try to copy and paste but error result. see image below
24406

Please help me to arrange this code to run with pictures.

here the code with the code from you.






Private Sub Worksheet_Change(ByVal Target As Range)




If Target.Cells.Count > 1 Then Exit Sub


If Target.Column = 2 Then
Application.EnableEvents = False
Cells(Target.Row + 1, "A").Select
Application.EnableEvents = True
End If


End Sub
Private Sub Worksheet_Change(ByVal Target As Range)


If Target.Count <> "1" Or Target.Column <> 2 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 Stringa
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" & Application.PathSeparator
' the path to the folder witl aal the photos
photoPath = "G:\sample\" & Application.PathSeparator

Set Cell = Target
If Not Cell.Column = 2 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 = 250
.IncrementLeft 0.75
.IncrementTop -200
End With
rng.Offset(1, -rng.Column + 2).Select
Return


End Sub

大灰狼1976
06-20-2019, 12:48 AM
Hi forerver!
No process with the same name can occur. You need to merge the code.


Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Count <> "1" Or Target.Column <> 2 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 Stringa
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" & Application.PathSeparator
' the path to the folder witl aal the photos
photoPath = "G:\sample\" & Application.PathSeparator

Set Cell = Target
If Not Cell.Column = 2 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 = 250
.IncrementLeft 0.75
.IncrementTop -200
End With
'rng.Offset(1, -rng.Column + 2).Select
If Target.Column = 2 Then Target.Offset(1, -1).Select
Return

End Sub