Icaros Diego: Msgbox cuando se cumpla nueva condición.Sr Amor
Hola experto.
Este es el otro supuesto:
Cuando haya 2 “x” contiguas, un hueco y una “x” el msgbox debe llamar la atención sobre la celda vacía que queda en medio. En cualquiera de las dos direcciones (es decir cuando haya “x”,”x”,hueco, “x”; o cuando haya “x”, hueco, “x”,”x”.
Gracias
Un cordial saludo
1 Respuesta
Respuesta de Dante Amor
1
Te anexo la macro para contar los de en medio.
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
If Not Intersect(Target, Range("A:A")) Is Nothing Then
If Target.Count = 1 Then
Set b = Range("C1:U1").Find(Target, LookAt:=xlWhole)
If Not b Is Nothing Then
u = Cells(Rows.Count, b.Column).End(xlUp).Row + 1
Cells(u, b.Column) = "x"
cuenta3 u, b.Column
cuenta2 u, b.Column
End If
End If
End If
End Sub
Sub cuenta3(f, c)
'Por.Dante Amor
If Cells(f, c - 2) = "x" And Cells(f, c - 1) = "x" Then
existe = True
a = -3
p = 1
ElseIf Cells(f, c - 1) = "x" And Cells(f, c + 1) = "x" Then
existe = True
a = -2
p = 2
ElseIf Cells(f, c + 1) = "x" And Cells(f, c + 2) = "x" Then
existe = True
a = -1
p = 3
End If
If existe Then
cad = ""
If Cells(f, c + a) = "" Then
cad = Cells(1, c + a)
End If
If Cells(f, c + p) = "" And Cells(1, c + p) <> "" Then
If cad <> "" Then
cad = cad & " y " & Cells(1, c + p)
Else
cad = Cells(1, c + p)
End If
End If
If cad <> "" Then
MsgBox "Atención sobre " & cad
End If
End If
End Sub
Sub cuenta2(f, c)
'Por.Dante Amor
On Error Resume Next
If Cells(f, c + 3) = "x" And Cells(f, c + 1) = "x" And Cells(f, c + 2) = "" Then
existe = True
m = 2
ElseIf Cells(f, c + 1) = "x" And Cells(f, c - 2) = "x" And Cells(f, c - 1) = "" Then
existe = True
m = -1
ElseIf Cells(f, c - 3) = "x" And Cells(f, c - 1) = "x" And Cells(f, c - 2) = "" Then
existe = True
m = -2
ElseIf Cells(f, c - 1) = "x" And Cells(f, c + 2) = "x" And Cells(f, c + 1) = "" Then
existe = True
m = 1
ElseIf Cells(f, c + 3) = "x" And Cells(f, c + 2) = "x" And Cells(f, c + 1) = "" Then
existe = True
m = 1
ElseIf Cells(f, c - 3) = "x" And Cells(f, c - 2) = "x" And Cells(f, c - 1) = "" Then
existe = True
m = -1
End If
werr = Err.Number
If Err.Number = 0 Then
If existe Then
MsgBox "Atención sobre " & Cells(1, c + m)
End If
End If
Err.Number = 0
End SubSaludos.Dante Amor
No olvides valorar la respuesta.
