i'm clueless, i'm trying to build a code that input a prefix to a cell value after i change that cell, i mean i'll select a cell and input "342" for example, after i update that value i want the private sub to change that cell value to "GO-342", i've tried this, but it dosen't work.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$D$3" Then
If Left(Range("D3"), 2) = "GO" Then Exit Sub
Range("D3") = "GO-" & Range("D3")
End If
End Sub
the entire code:
Private Sub Worksheet_Change(ByVal Target As Range)
'Cabeçalho
Dim rng As Range
Set rng = Range("D3,D5,I3,O3,O5,O7,X3,X5")
If Intersect(Target, rng) Is Nothing Then Exit Sub
For Each R In rng
If R.Value = "" Then
Exit Sub
End If
Next R
Create
'Km
Dim rng1 As Range
Set rng1 = Range("X3,X5")
If Intersect(Target, rng1) Is Nothing Then Exit Sub
For Each R In rng1
If R.Value = "" Then
Exit Sub
End If
Next R
Km
'GO
If Target.Address = "$D$3" Then
If Left(Range("D3"), 2) = "GO" Then Exit Sub
Application.EnableEvents = False
Range("D3") = "GO-" & Range("D3")
Application.EnableEvents = True
End If
End Sub
"Cabeçalho" and "Km" works but "GO" dosen't
Here is a tiny mod to your code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$D$3" Then
If Left(Range("D3"), 2) = "GO" Then Exit Sub
Application.EnableEvents = False
Range("D3") = "GO-" & Range("D3")
Application.EnableEvents = True
End If
End Sub
The code must be placed in the worksheet code area.Macros must be enabled.
Related
I have a problem with VBA, I need to use the worksheet change event to pickup cell values from AI28 to AI30 and move them over to V28 to V30. This is what I have do so far
Private Sub Worksheet_Change(ByVal Target As Range)
If IsNumeric(Target) And Not (Target = "") Then
If Target.Address = Range("AI28:AI30").Address Then
Range("V28:V30").Value = Range("AH28:AH30").Value
Else
If Target.Cells.Value <> Empty Then Exit Sub
Exit Sub
End If
End If
End Sub
It works fine for just one range eg AI28 and V28 so what am I missing? A loop or something?
Use a loop and Intersect:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Set rng = Intersect(Target, Me.Range("AI28:AI30"))
If rng Is Nothing Then Exit Sub
On Error GoTo SafeExit
Application.EnableEvents = False
Dim cell As Range
For Each cell In rng
If IsNumeric(cell.Value) And Not IsEmpty(cell.Value) Then
Me.Range("V" & cell.Row).Value = cell.Value
End If
Next
SafeExit:
Application.EnableEvents = True
End Sub
I am using the below codes to change the "Sheet2" "D2" value as per the value in "Sheet1" "B2" and VICE VERSA too. But they are not working together. If I use them separately then both coding is working perfectly. How can I correct them to perform together?
"Sheet1"
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B2")) Is Nothing Then
Select Case Target.Value
Case Is = "Included": Worksheets("Sheet2").Range("D2") = Target.Value
Case Is = "Excluded": Worksheets("Sheet2").Range("D2") = Target.Value
End Select
End If
End Sub
"Sheet2"
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("D2")) Is Nothing Then
Select Case Target.Value
Case Is = "Included": Worksheets("Sheet1").Range("B2") = Target.Value
Case Is = "Excluded": Worksheets("Sheet1").Range("B2") = Target.Value
End Select
End If
End Sub
From comments above:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, v
Set rng = Intersect(Target, Me.Range("B2"))
If Not rng Is Nothing Then
v = Target.Value
If v = "Included" Or v = "Excluded" Then
On Error GoTo haveError 'set up error handling
Application.EnableEvents = False 'disable events
ThisWorkbook.Worksheets("Sheet2").Range("D2") = v
Application.EnableEvents = True 're-enable events
End If
End If
Exit Sub 'normal exit
haveError:
Application.EnableEvents = True 'make sure events not left turned off
End Sub
I am trying to combine these two codes, the first one is to change the name of my worksheet when I change the value of the cell m3, and the second code is to block the cells after modifying the cells. I am new in VBA so I don't know how to combine them.
CODE 1
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$M$3" Then RenameSheet
End Sub
CODE 2
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xRg As Range
On Error Resume Next
Set xRg = Intersect(Range("F6"), Target)
If xRg Is Nothing Then Exit Sub
Target.Worksheet.Unprotect Password:="1234"
xRg.MergeArea.Locked = True
Target.Worksheet.Protect Password:="1234"
End Sub
Also sub renamesheet code is:
Sub RenameSheet()
Dim rs As Worksheet
For Each rs In Sheets
If rs.Name <> "MENU" And rs.Name <> "CAJA_CONTABILIDAD" Then
rs.Name = "Vale " & rs.Range("M3")
End If
Next rs
If Target.Address = "$M$3" Then RenameSheet
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$M$3" Then
RenameSheet
Exit Sub
End If
Dim xRg As Range
Set xRg = Intersect(Range("F6"), Target)
On Error Resume Next
If Not xRg Is Nothing Then
Target.Worksheet.Unprotect Password:="1234"
xRg.MergeArea.Locked = True
Target.Worksheet.Protect Password:="1234"
End If
End Sub
good morning
I need to combine two Private Sub Worksheet_Change(ByVal Target As Range) I'm new to Excel VBA code, how can I do this? Code below.
1)
Option Explicit
Const strAFM As String = "D3:D1000"
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, AFM As String, rngTomi As Range
Set Rng = Range(strAFM)
Set rngTomi = Intersect(Target, Rng)
If rngTomi Is Nothing Then Exit Sub
If rngTomi.Count <> 1 Then
rngTomi.ClearContents
Exit Sub
End If
If Trim(Target.Value) = "" Then Exit Sub
AFM = Right("000000000" & Target.Value, 9)
If isAFM(AFM) = False Then
MsgBox "no afm"
Target.Activate
Exit Sub
End If
End Sub
2)
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
Dim Rng As Range
Set Rng = Me.Range("ColTarget")
If Intersect(Target, Rng) Is Nothing Then Exit Sub
ResizeTbl
End Sub
Try:
Option Explicit
Const strAFM As String = "D3:D1000"
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, AFM As String, rngTomi As Range
If Not Target.Count > 1 Then
Set Rng = Me.Range("ColTarget")
If Not Intersect(Target, Rng) Is Nothing Then ResizeTbl
End If
Set Rng = Range(strAFM)
Set rngTomi = Intersect(Target, Rng)
If Not rngTomi Is Nothing Then
If rngTomi.Count <> 1 Then
Application.EnableEvents = False
rngTomi.ClearContents
Application.EnableEvents = False
Exit Sub
End If
If Trim(Target.Value) = "" Then Exit Sub
AFM = Right("000000000" & Target.Value, 9)
If isAFM(AFM) = False Then
MsgBox "no afm"
Target.Activate
Exit Sub
End If
End If
End Sub
The code below is causing an error when I paste information onto the sheet.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A1 As Range
Set A1 = Range("A:I")
If Not Intersect(Target, A1) Is Nothing Then
Application.EnableEvents = False
Target.Value = UCase(Target.Value)
Application.EnableEvents = True
End If
End Sub
The code is specific to the sheet (right click on tab an view code).
Could you please advise on how to fix this?
Thanks in advance.
Loop over the intersection cells if they exists:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A1 As Range, intr As Range, r As Range
Set A1 = Range("A:I")
Set intr = Intersect(A1, Target)
If Not intr Is Nothing Then
Application.EnableEvents = False
For Each r In intr
r.Value = UCase(r.Value)
Next r
Application.EnableEvents = True
End If
End Sub
The error is because of Target.Value = UCase(Target.Value) is not suitable for multiple cells. Thus a loop is needed:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo WorksheetChange_Error
Application.EnableEvents = False
Dim A1 As Range
Set A1 = Range("A:I")
If Not Intersect(Target, A1) Is Nothing Then
Dim myCell As Range
For Each myCell In Target.Cells
myCell = UCase(myCell)
Next
End If
Application.EnableEvents = True
Exit Sub
WorksheetChange_Error:
Application.EnableEvents = True
MsgBox Err.Description
End Sub
The error handler is used to reset the EnableEvents = True, if some kind of unexpected error comes.