En un, Private Sub Worksheet_Change(ByVal Target As Range), se podria separar en dos macros.
En esta macro:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("F5:G19, L5:M19")) Is Nothing Then
' Estadillo unicaja
'Desactiva los eventos
Application.EnableEvents = False
' Para quitar el espacio+letras
Range("F5:G19").Replace What:=" EUR", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
' Alinear a la izquierda
Range("E6:E19").HorizontalAlignment = xlLeft
' Convertir a Numero
Range("F5:G19").Select
For Each cd In Selection
On Error Resume Next
'si Val devuelve 0 es porque se trata de celdas con texto, no números guardados como texto
If Val(cd) <> 0 Then
cd.Value = cd.Value * 1
End If
Next
' Ingresar filas vacias
Range("B6:G19").Select
Selection.Insert Shift:=xlDown
' Eliminar filas vacias
Range("B20:G40").Cells.SpecialCells(xlCellTypeBlanks).Delete xlUp
' ESTADILLO ING DIRECT
' Para quitar el espacio+letras
Range("L5:M19").Replace What:=" EUR", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
' Alinear a la izquierda
Range("K6:K19").HorizontalAlignment = xlLeft
' Convertir a Numero
Range("L5:M19").Select
For Each cd In Selection
On Error Resume Next
'si Val devuelve 0 es porque se trata de celdas con texto, no números guardados como texto
If Val(cd) <> 0 Then
cd.Value = cd.Value * 1
End If
Next
' Ingresar filas vacias
Range("I6:M19").Select
Selection.Insert Shift:=xlDown
' Eliminar filas vacias
Range("I20:M40").Cells.SpecialCells(xlCellTypeBlanks).Delete xlUp
'
'Activa los eventos
Application.EnableEvents = True
End If
End Sub
Se podria que si uso la parte del :
' Estadillo unicaja
No se ejecute la parte del :
' ESTADILLO ING DIRECT
1 Respuesta
H o l a:
Te anexo el código para que funcione con 2 rangos:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("F5:G19")) Is Nothing Then
' Estadillo unicaja
'Desactiva los eventos
Application.EnableEvents = False
' Para quitar el espacio+letras
Range("F5:G19").Replace What:=" EUR", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' Alinear a la izquierda
Range("E6:E19").HorizontalAlignment = xlLeft
' Convertir a Numero
For Each cd In Range("F5:G19")
On Error Resume Next
'si Val devuelve 0 es porque se trata de celdas con texto, no números guardados como texto
If Val(cd) <> 0 Then
cd.Value = cd.Value * 1
End If
Next
' Ingresar filas vacias
Range("B6:G19").Select
Selection.Insert Shift:=xlDown
' Eliminar filas vacias
Range("B20:G40").Cells.SpecialCells(xlCellTypeBlanks).Delete xlUp
Application.EnableEvents = False
End If
'
If Not Intersect(Target, Range("L5:M19")) Is Nothing Then
' ESTADILLO ING DIRECT
Application.EnableEvents = False
Range("L5:M19").Replace What:=" EUR", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Range("K6:K19").HorizontalAlignment = xlLeft
For Each cd In Range("L5:M19")
On Error Resume Next
If Val(cd) <> 0 Then
cd.Value = cd.Value * 1
End If
Next
Range("I6:M19").Select
Selection.Insert Shift:=xlDown
Range("I20:M40").Cells.SpecialCells(xlCellTypeBlanks).Delete xlUp
Application.EnableEvents = True
End If
End Sub':) 'S aludos. D a n t e A m o r . R ecuerda valorar la respuesta. G racias ':)
