Macro para buscar datos según la intersección fila y columna
Como realizar una Macro que busque varios números en distintas hojas, dentro de matrices distintas, cuyo resultado se encuentra en la intersección de fila y columna.
Los números a buscar se encuentran en tres lugares, dos en esta hoja que se denomina "1.INGRESO DATOS, ARCANOS" y otro en la hoja "7.Casa x Casa."
1) Buscar en la matriz Q14:AX30, el resultado se encuentra en Columna O14:O30 y P14:P30 y en la fila Q12:AX12 y Q13:AX13 (color de relleno ROSA) y el resultado debe quedar expresado así
Texto Columna O (número columna P) / Texto Fila 12 (número fila 13)
2) Segundo lugar a buscar L12:N35 y el resultado en la columna C12:C35 (color de relleno verde agua) y el resultado debe quedar expresado
ARCANO CASA y número columna C
Por ejemplo se busca el 23
ARCANO CASA 5
3) SE BUSCA EN LA SIGUIENTE HOJA denominada "7.Casa x Casa"
Buscar en D4:AA39, y los resultados se encuentran en COLUMNA B (C) / FILA 2 (3), cuyo resultado seria Texto Columna B (número columna C) / Texto Fila 2 (número fila 3)
Y si el resultado esta dentro de los valores en amarillo, el resultado debe decir
Encrucijada (texto columna b)
Los resultados los tengo que poner en una hoja nueva denominada RESULTADOS.
Que contenga 10 columnas con números a buscar y 25 filas cada uno para resultados.
Y esto que se repita 15 veces para abajo. Es decir que el total de MACROS seria 15 .
H o l a:
Te anexo la macro para buscar en el rango L2:N35
Sub Buscar()
'Por.Dante Amor
Set h1 = Sheets("Ingreso datos,Arcanos")
Set h2 = Sheets("RESULTADOS")
'
'u = h2.Range("C" & Rows.Count).End(xlUp).Row
u = h2.UsedRange.Rows(h2.UsedRange.Rows.Count).Row
If u < 5 Then u = 5
h2.Range("C5:AA" & u).ClearContents
Set r = h1.Range("Q14:AX30")
Set r2 = h1.Range("L12:N35")
'
For j = 3 To h2.Cells(3, Columns.Count).End(xlToLeft).Column
f = 5
Set b = r.Find(What:=h2.Cells(4, j), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not b Is Nothing Then
ncell = b.Address
Do
'detalle
If h1.Cells(b.Row, "P") <> "" Then
izq1 = ObtenerDato(h1.Cells(b.Row, "O"))
izq2 = ObtenerDato(h1.Cells(b.Row, "P"))
top1 = ObtenerDato(h1.Cells(12, b.Column))
top2 = ObtenerDato(h1.Cells(13, b.Column))
cad = izq1 & "(" & izq2 & ")" & " / " & top1 & "(" & top2 & ")"
h2.Cells(f, j) = cad
f = f + 1
If f = 31 Then Exit For
End If
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
'
Set b = r2.Find(What:=h2.Cells(4, j), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not b Is Nothing Then
ncell = b.Address
Do
'detalle
'If h1.Cells(b.Row, "P") <> "" Then
izq1 = ObtenerDato(h1.Cells(b.Row, "C"))
'izq2 = ObtenerDato(h1.Cells(b.Row, "P"))
'top1 = ObtenerDato(h1.Cells(12, b.Column))
'top2 = ObtenerDato(h1.Cells(13, b.Column))
cad = "ARCANO CASA " & izq1
h2.Cells(f, j) = cad
f = f + 1
If f = 31 Then Exit For
'End If
Set b = r2.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
Next
MsgBox "Fin"
End Sub
'
Function ObtenerDato(dato)
'Por.Dante Amor
If dato.MergeCells Then
ObtenerDato = dato.MergeArea.Cells(1, 1)
Else
ObtenerDato = dato
End If
End Function':)
'S aludos. D a n t e A m o r . R ecuerda valorar la respuesta. G racias
':)
