realizar dos procesos al mismo tiempo en cada cambio de celda

dragonfire33

Board Regular
Joined
Oct 7, 2021
Messages
52
Office Version
  1. 365
Platform
  1. Windows
como puedo ejecutar estos dos codigos en cada cambio de cleda de una columna AS
VBA Code:
Sub coincidencias()
'ajustada x Elsamatilde
Dim n As Range
Dim lookup
ElRango = "A1:AG45"
'se solicita ingreso del nro de 4 dígitos
lookup = Format(Val(InputBox("ingrese NUMERO de referencia", "BUSQUEDA DE COINCIDENCIAS")), "0000")
If Val(lookup) = 0 Then
    Columns("AJ:AJ").Clear
    [AK1].ClearContents
    For LaFila = 1 To Range(ElRango).Rows.Count 'Step 5
        'si la celda en col E es amarilla se deja la fila en amarillo
        If Range("A" & LaFila).Interior.ColorIndex = 6 Then
            'se asigna color 6 a la fila completa, no x col
            Range("A" & LaFila & ":AF" & LaFila).Interior.ColorIndex = 6
            'For LaColu = 0 To Range(ElRango).Columns.Count - 1
               'Range("E1").Offset(LaFila, LaColu).Interior.ColorIndex = 6
            'Next
        Else
            'sino se le quita el color que tenga de la coincidencia
            Range("A" & LaFila & ":AF" & LaFila).Interior.ColorIndex = xlNone
        End If
    Next
    Exit Sub
Else
    If Len(lookup) <> 4 Then
        MsgBox "Número no válido.", , "ERROR"
        Exit Sub
    End If
End If
'se guarda en Z1 y se da formato a la celda
With [AK1]
    .Value = lookup
    .NumberFormat = "0000"
    .Font.Bold = True
    .HorizontalAlignment = xlLeft
    .Interior.ColorIndex = 44     '(naranja)
End With
'se recorre el rango buscando las 6 coincidencias
'se limpia la col Y
Columns("AJ:AJ").Clear
x = 2
For Each n In Range(ElRango)
    If n = lookup Or Left(n.Value, 2) = Left(lookup, 2) Or Right(n.Value, 2) = Right(lookup, 2) Or _
        (Left(n.Value, 1) = Left(lookup, 1) And Right(n.Value, 1) = Right(lookup, 1)) Or _
        (Left(n.Value, 1) = Left(lookup, 1) And Mid(n.Value, 3, 1) = Mid(lookup, 3, 1)) Or _
        (Mid(n.Value, 2, 1) = Mid(lookup, 2, 1) And Right(n.Value, 1) = Right(lookup, 1)) Or _
        (Mid(n.Value, 2, 1) = Mid(lookup, 2, 1) And Mid(n.Value, 3, 1) = Mid(lookup, 3, 1)) Then
            n.Interior.ColorIndex = 4   'verde
            'se agrega el nro a la col Y
            Range("AJ" & x) = n
            x = x + 1
    Else   'opcional quitar color a los no coincidentes.
        'n.Interior.Color = xlNone
    End If
Next n
MsgBox "Fin del proceso.", , "INFORMACIÓN"
End Sub


Sub buscar_reemplazar_color()
'preparar col AP
With Range("AQ:AQ")
    .ClearContents
    .NumberFormat = "@"
End With
x = Range("AL" & Rows.Count).End(xlUp).Row
finy = 2
For Z = 2 To x
    nrox = Format(Range("AL" & Z) & Range("AM" & Z) & Range("AN" & Z) & Range("AO" & Z), "0000")
    If InStr(1, UCase(nrox), "X", 0) = 0 Then
        Range("AQ" & finy) = nrox: finy = finy + 1
    End If
Next Z

Set DATOS = Range("A1:AG45").CurrentRegion
Set lista = Range("AQ1").CurrentRegion
MATRIZ = DATOS
With lista
    For i = 2 To .Rows.Count
        numeros = .Cells(i, 1)
        cuenta = WorksheetFunction.CountIf(DATOS, numeros)
        If cuenta > 0 Then
            For J = 1 To cuenta
                If J = 1 Then Set busca = DATOS.Find(Format(numeros, "0000"), lookat:=xlWhole)
                If J > 1 Then Set busca = DATOS.FindNext(busca)
                On Error Resume Next
                celda = busca.Address
                With Range(celda)
                    .Interior.ColorIndex = 7    'rojo
                    .Select
                End With
            Next J
        Else
            GoTo SIGUIENTE
        End If
        On Error GoTo 0
SIGUIENTE:
    Next i
End With
SALIDA:
End Sub
 

Attachments

  • 11.png
    11.png
    210.6 KB · Views: 17

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().

Forum statistics

Threads
1,214,895
Messages
6,122,128
Members
449,066
Latest member
Andyg666

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top