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
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