jhon666
Desconectado
Mensajes: 2
|
la idea es colocar un numero de 4 cifras en la celda A1 o si lo deseas puedes dividirlo en 4 celdas por ejemplo A1 o A1 B1 C1 D1 1234 1 2 3 4 luego a partir de la celda E1 estan los numeros asi
3 5 7 9 8 2 6 0 0 8 6 4 8 4 0 6 2 4 6 8 6 0 4 8 6 4 2 0 6 6 la idea es buscar las 6 coincidencias posibles como son las dos primeras, las dos ultimas, la primera y la tercera,la primera y la cuarta,la segunda y la ultima,la segunda y la tercera y la resalte con un color como lo dije anteriormente en forma horizontal y diagonalmente de arriba hacia abajo y de izquierda a derecha solo esos dos metodos el rango es ("E1;CE26") Tengo esta macro que me busca las dos coincidencias pero celda por celda tal vez te sirva de base para que me ayudes Sub coincidencias()
Dim n As Range Dim lookup
'se solicita ingreso del nro de 4 dígitos lookup = Format(Val(InputBox("ingrese NUMERO de referencia", "BUSQUEDA DE COINCIDENCIAS")), "0000") If Len(lookup) <> 4 Then MsgBox "Número no válido.", , "ERROR" Exit Sub End If 'se guarda en AH1 y se da formato a la celda With [AH1] .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 AG Columns("AG:AG").Clear x = 2 For Each n In Range("A1:AE44") 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 'se agrega el nro a la col AG Range("AG" & 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 y en internet he encontrado esta macro pero busca es todo el numero completo como en una sopa de letras y no las coincidencias Sub sopa_de_letras() 'Por.Dante Amor Set r = Range("C3").Resize(40, 50) r.Interior.ColorIndex = xlNone For i = 3 To Range("A" & Rows.Count).End(xlUp).Row Set b = r.Find(Left(Cells(i, "A"), 1), lookat:=xlWhole) If Not b Is Nothing Then ncell = b.Address Do For k = 1 To 2 resto = Mid(Cells(i, "A"), 2, Len(Cells(i, "A"))) If busca(r, resto, k, b.Row, b.Column, False) Then pintar = busca(r, resto, k, b.Row, b.Column, True) Exit Do End If Next Set b = r.FindNext(b) Loop While Not b Is Nothing And b.Address <> ncell End If Next End Sub Function busca(r, resto, k, f, c, si) 'por.Dante Amor For i = 1 To IIf(si, Len(resto) + 1, Len(resto)) If si Then Cells(f, c).Interior.ColorIndex = 4 Select Case k Case 1: f = f + 0: c = c + 1 Case 2:: f = f + 1: c = c + 1 End Select If f >= r.Rows(1).Row And f <= r.Rows(r.Rows.Count).Row _ And c >= r.Columns(1).Column And c <= r.Columns(r.Columns.Count).Column Then If Cells(f, c) = Mid(resto, i, 1) Then continua = True Else continua = False Exit For End If Else continua = False Exit For End If Next busca = continua End Function muchas gracias por la colaboracion espero que me ayudes
|