No soy capaz de acoplar esta macro en hoja
Tengo esta macro en la hoja:
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
Set r = Range("D136:D450")
If Not Intersect(Target, r) Is Nothing Then
If Target.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
'
cuenta = WorksheetFunction.CountIf(r, Target.Value)
If cuenta > 1 Then
MsgBox "Valor duplicado", vbCritical
Application.EnableEvents = False
Target.Value = ""
Application.EnableEvents = True
Target.Select
End If
End If
End Sub
Y necesito acoplarla a la que tengo, que es esta:
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
If Not Intersect(Target, Range("D7,C10:E2000")) Is Nothing Then
ActiveSheet.Unprotect Password:="1"
Application.EnableEvents = False
For Each C In Target
If Not Intersect(C, Range("D10:D791")) Is Nothing Then
If Range("B" & C.Row) = "" Then
Range("B" & C.Row) = Date - 1
Else
Range("B" & C.Row & ":E" & C.Row).Font.Bold = True
Range("B" & C.Row & ":E" & C.Row).Interior.ColorIndex = 3
Range("B" & C.Row & ":E" & C.Row).Font.ColorIndex = 2
End If
End If
C.Value = UCase(C.Value)
Next
Application.EnableEvents = True
ActiveSheet.Protect Password:="1"
End If
'
ActiveSheet.Unprotect Password:="1"
If Not Intersect(Target, Range("D7")) Is Nothing Then
u = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
Range("F10").Select
Selection.EntireColumn.Hidden = False ' MOSTRAR COLUMNA
Range("P10").Select
Selection.EntireColumn.Hidden = True ' OCULTAR COLUMNA
If [D7] = "" Then Exit Sub
Range("A9:P" & u).AdvancedFilter Action:=xlFilterInPlace, _
CriteriaRange:=Range("D6:D7"), Unique:=False
Call Celdas_muestra
' Range("F10").Select
' Selection.EntireColumn.Hidden = True ' OCULTAR COLUMNA
' Range("P10").Select
' Selection.EntireColumn.Hidden = False ' MOSTRAR COLUMNA
End If
ActiveSheet.Protect Password:="1"
End Sub
Por más que lo intento, soy incapaz
1 Respuesta
Prueba con la siguiente:
Private Sub Worksheet_Change(ByVal Target As Range)
'Act.Por.Dante Amor
If Not Intersect(Target, Range("D7,C10:E2000")) Is Nothing Then
ActiveSheet.Unprotect Password:="1"
Application.EnableEvents = False
For Each C In Target
If Not Intersect(C, Range("D10:D791")) Is Nothing Then
If Range("B" & C.Row) = "" Then
Range("B" & C.Row) = Date - 1
Else
Range("B" & C.Row & ":E" & C.Row).Font.Bold = True
Range("B" & C.Row & ":E" & C.Row).Interior.ColorIndex = 3
Range("B" & C.Row & ":E" & C.Row).Font.ColorIndex = 2
End If
End If
C.Value = UCase(C.Value)
Next
Application.EnableEvents = True
ActiveSheet.Protect Password:="1"
End If
'
'*******************************
'
If Not Intersect(Target, Range("D7")) Is Nothing Then
ActiveSheet.Unprotect Password:="1"
u = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
'
Range("F10").EntireColumn.Hidden = False ' MOSTRAR COLUMNA
Range("P10").EntireColumn.Hidden = True ' OCULTAR COLUMNA
If [D7] = "" Then
'Exit Sub
Else
Range("A9:P" & u).AdvancedFilter Action:=xlFilterInPlace, _
CriteriaRange:=Range("D6:D7"), Unique:=False
Call Celdas_muestra
' Range("F10").Select
' Selection.EntireColumn.Hidden = True ' OCULTAR COLUMNA
' Range("P10").Select
' Selection.EntireColumn.Hidden = False ' MOSTRAR COLUMNA
End If
ActiveSheet.Protect Password:="1"
End If
'
'*******************************
'
'Por.Dante Amor
Set r = Range("D136:D450")
If Not Intersect(Target, r) Is Nothing Then
If Target.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
'
cuenta = WorksheetFunction.CountIf(r, Target.Value)
If cuenta > 1 Then
MsgBox "Valor duplicado", vbCritical
Application.EnableEvents = False
Target.Value = ""
Application.EnableEvents = True
Target.Select
End If
End If
End Subsal u dos
