Realizar búsqueda en forma diagonal en excel

Espero que te sirva

Option Explicit
Enum Direccion
    xlBuscarHaciaArriba = 1
    xlBuscarHaciaAbajo = 2
    xlBuscarHaciaDerecha = 3
    xlBuscarHaciaIzquierda = 4
    xlBuscarDiagonalArribaDerecha = 5
    xlBuscarDiagonalAbajoDerecha = 6
    xlBuscarDiagonalArribaIzquierda = 7
    xlBuscarDiagonalAbajoIzquierda = 8
End Enum
Public Function BuscarDiagonal(ByRef Origen As Range, ByVal Sentido As Direccion, ByVal CadenaABuscar As String) As String
    Dim i As Integer
    Dim dFila As Double
    Dim dColumna As Double
    Dim dIncrementoHorizontal As Double
    Dim dIncrementoVertical As Double
    Dim sLetra As String
    Dim sMensaje As String
    Dim bBuscar As Boolean
    Dim bEncontrado As Boolean
    Dim shHojaBusqueda As Worksheet
    Dim oCelda As Range
    ' Convertimos a mayusculas
    CadenaABuscar = UCase(CadenaABuscar)
    dIncrementoHorizontal = 0
    dIncrementoVertical = 0
    bBuscar = True
    bEncontrado = True
    Select Case Sentido
        Case xlBuscarHaciaArriba
            dIncrementoHorizontal = 0
            dIncrementoVertical = -1
        Case xlBuscarHaciaAbajo
            dIncrementoHorizontal = 0
            dIncrementoVertical = 1
        Case xlBuscarHaciaDerecha
            dIncrementoHorizontal = 1
            dIncrementoVertical = 0
        Case xlBuscarHaciaIzquierda
            dIncrementoHorizontal = -1
            dIncrementoVertical = 0
        Case xlBuscarDiagonalArribaDerecha
            dIncrementoHorizontal = 1
            dIncrementoVertical = -1
        Case xlBuscarDiagonalAbajoDerecha
            dIncrementoHorizontal = 1
            dIncrementoVertical = 1
        Case xlBuscarDiagonalArribaIzquierda
            dIncrementoHorizontal = -1
            dIncrementoVertical = -1
        Case xlBuscarDiagonalAbajoIzquierda
            dIncrementoHorizontal = -1
            dIncrementoVertical = 1
        Case Else
            bBuscar = False
    End Select
    ' Tenemos que identificar la hojo de busqueda
    Set shHojaBusqueda = Origen.Worksheet
    If Origen.Cells.Count = 1 Then
        If Len(Trim(CadenaABuscar)) > 0 Then
            dFila = Origen.Row
            dColumna = Origen.Column
            If bBuscar = True Then
                For i = 0 To Len(CadenaABuscar) - 1
                    sLetra = shHojaBusqueda.Cells(dFila + i * dIncrementoVertical, dColumna + i * dIncrementoHorizontal).Value
                    Debug.Print "(" & (dFila + i * dIncrementoVertical) & "," & (dColumna + i * dIncrementoHorizontal) & ") : " & sLetra
                    If sLetra = Mid(CadenaABuscar, i + 1, 1) Then
                    Else
                        bEncontrado = False
                        Exit For
                    End If
                Next
                If bEncontrado = True Then
                    sMensaje = CadenaABuscar
                Else
                    sMensaje = "-"
                End If
            Else
                sMensaje = "Direccion de busqueda incorrecto"
            End If
        Else
            sMensaje = "La cadena de busqueda no puede ser vacia"
        End If
    Else
        sMensaje = "El origen solo puede ser una celda"
    End If
    BuscarDiagonal = sMensaje
End Function

como la ejecuto como sub cadenaabuscar o busqueda diagonal

como funciona paso por paso por favor

La idea es que sea una función, admite 3 parámetros que son:

• Origen : Es una referencia a la celda desde donde queremos buscar
• Dirección : Es un numero, nos indica el sentido de búsqueda
• Cadena : Es la cadena que queremos buscar

Un ejemplo de uso seria:

BuscarDiagonal(<Referencia a la celda desde donde queremos buscar>,
               <Direccion de busqueda>,
               <Cadena a buscar>)

' Recordar cuales son los sentidos de busqueda:
'    xlBuscarHaciaArriba = 1
'    xlBuscarHaciaAbajo = 2
'    xlBuscarHaciaDerecha = 3
'    xlBuscarHaciaIzquierda = 4
'    xlBuscarDiagonalArribaDerecha = 5
'    xlBuscarDiagonalAbajoDerecha = 6
'    xlBuscarDiagonalArribaIzquierda = 7
'    xlBuscarDiagonalAbajoIzquierda = 8
'
' Para buscar en todas las direcciones con un bucle For:
'   Valor inicial: xlBuscarHaciaArriba
'   Valor final  : xlBuscarDiagonalAbajoIzquierda 
'
Sub Ejemplo()
    Dim iDireccionBusqueda As Integer
    Dim sCeldaOrigen As String
    Dim sCadenaBuscada As String
    Dim shHoja As Worksheet
    Dim oCelda As Range
    ' Seleccionamos la hoja Activa
    Set shHoja = ActiveSheet
    ' El punto de busqueda es la celda G10
    sCeldaOrigen = "G10"
    Set oCelda = shHoja.Range(sCeldaOrigen)
    ' La cadena a buscar es GALLIFANTE
    sCadenaBuscada = "GALLIFANTE"
    ' Buscamos la celda en todas las direcciones
    For iDireccionBusqueda = xlBuscarHaciaArriba To xlBuscarDiagonalAbajoIzquierda
        If BuscarDiagonal(oCelda, iDireccionBusqueda, sCadenaBuscada) = sCadenaBuscada Then
            ' Hemos encontrado la cadena
        Else
            ' No hemos encontrado la cadena
        End If
    Next
End Sub

Si encuentra la cadena, te devuelve la cadena, en caso contrario te devuelve un el carácter '-'. También se controlan algunos errores:

• El rango que se pasa es una única celda
• El sentido/dirección de búsqueda es uno válido
• La cadena no es vacía

Quizás con esta foto se vea un poco mejor la idea:

De todas formas si me pasa un ejemplo con más detalle quizás te pueda dar una respuesta mas adaptada.

Nota: La función actual no comprobaba si te sales de la hoja, para ello la nueva función quedaría de la siguiente forma:

Option Explicit
' Constantes
' Definimos cuales son limites maximos de busqueda
Const cMaxFilas = 65536
Const cMaxColumns = 65536
' Enum
' Direcciones/Sentidos de busqueda
Enum Direccion
    xlBuscarHaciaArriba = 1
    xlBuscarHaciaAbajo = 2
    xlBuscarHaciaDerecha = 3
    xlBuscarHaciaIzquierda = 4
    xlBuscarDiagonalArribaDerecha = 5
    xlBuscarDiagonalAbajoDerecha = 6
    xlBuscarDiagonalArribaIzquierda = 7
    xlBuscarDiagonalAbajoIzquierda = 8
End Enum
' Funcion: BuscarDiagonal
' Descripcion: Busqueda direccional de cadenas
' -------------------------------------------------------------------------------------
' Parametros:
'   Origen        : Celda de referencia a partir de la cual buscamos la cadena
'   Sentido       : Direccion de busqueda
'   CadenaABuscar : Cadena que queremos buscar
' -------------------------------------------------------------------------------------
' Retorno: Si encuentra la cadena devuelve la cadena, en caso contrario el caracter -
'
Public Function BuscarDiagonal(ByRef Origen As Range, ByVal Sentido As Direccion, ByVal CadenaABuscar As String) As String
    Dim i As Integer
    Dim dFila As Double
    Dim dColumna As Double
    Dim dFilaNueva As Double
    Dim dColumnaNueva As Double
    Dim dIncrementoHorizontal As Double
    Dim dIncrementoVertical As Double
    Dim sLetra As String
    Dim sMensaje As String
    Dim bBuscar As Boolean
    Dim bEncontrado As Boolean
    Dim shHojaBusqueda As Worksheet
    Dim oCelda As Range
    ' Convertimos a mayusculas la cadena de busqueda
    CadenaABuscar = UCase(CadenaABuscar)
    ' Inicializamos los valores
    dIncrementoHorizontal = 0
    dIncrementoVertical = 0
    bBuscar = True
    bEncontrado = True
    Select Case Sentido
        Case xlBuscarHaciaArriba
            dIncrementoHorizontal = 0
            dIncrementoVertical = -1
        Case xlBuscarHaciaAbajo
            dIncrementoHorizontal = 0
            dIncrementoVertical = 1
        Case xlBuscarHaciaDerecha
            dIncrementoHorizontal = 1
            dIncrementoVertical = 0
        Case xlBuscarHaciaIzquierda
            dIncrementoHorizontal = -1
            dIncrementoVertical = 0
        Case xlBuscarDiagonalArribaDerecha
            dIncrementoHorizontal = 1
            dIncrementoVertical = -1
        Case xlBuscarDiagonalAbajoDerecha
            dIncrementoHorizontal = 1
            dIncrementoVertical = 1
        Case xlBuscarDiagonalArribaIzquierda
            dIncrementoHorizontal = -1
            dIncrementoVertical = -1
        Case xlBuscarDiagonalAbajoIzquierda
            dIncrementoHorizontal = -1
            dIncrementoVertical = 1
        Case Else
            bBuscar = False
    End Select
    ' Tenemos que identificar la hoja de busqueda
    Set shHojaBusqueda = Origen.Worksheet
    ' Comprobamos que el origen es una unica celda
    If Origen.Cells.Count = 1 Then
        ' Comprobamos que la cadena a buscar no es vacia
        If Len(Trim(CadenaABuscar)) > 0 Then
            dFila = Origen.Row
            dColumna = Origen.Column
            If bBuscar = True Then
                For i = 0 To Len(CadenaABuscar) - 1
                    ' Calculamos los valores de fila y columna a leer
                    dFilaNueva = dFila + i * dIncrementoVertical
                    dColumnaNueva = dColumna + i * dIncrementoHorizontal
                    ' Comprobamos que no nos salimos de los limites de la hoja
                    If (dFilaNueva > 0 And dFilaNueva < cMaxFilas) And (dColumnaNueva > 0 And dColumnaNueva < cMaxColumns) Then
                        sLetra = shHojaBusqueda.Cells(dFilaNueva, dColumnaNueva).Value
                        Debug.Print "(" & dFilaNueva & "," & dColumnaNueva & ") : " & sLetra
                        If sLetra = Mid(CadenaABuscar, i + 1, 1) Then
                            ' No hacemos nada, seguimos buscando
                        Else
                            bEncontrado = False
                            Exit For
                        End If
                    Else
                        bEncontrado = False
                        Exit For
                    End If
                Next
                ' Informamos el valor de retorno
                If bEncontrado = True Then
                    sMensaje = CadenaABuscar
                Else
                    sMensaje = "-"
                End If
            Else
                sMensaje = "Direccion de busqueda incorrecto"
            End If
        Else
            sMensaje = "La cadena de busqueda no puede ser vacia"
        End If
    Else
        sMensaje = "El origen solo puede ser una celda"
    End If
    ' Liberamos los objetos utilizados
    Set oCelda = Nothing
    Set shHojaBusqueda = Nothing
    ' Devolvemos el valor
    BuscarDiagonal = sMensaje
End Function

Envío imagen de ejemplo a lo que estoy buscando

Correo [email protected] para que me agregue y poder enviar la hoja de trabajo

¿Experto lo que quiero saber de la macro es que tengo que escribir entre celdas la palabra GALIFANTE comenzando desde la celda "G10" o sea que la imagen es solo una guía?

es que me sale el anterior error

Experto juan y si por favor me envía la hoja de trabajo al correo le agradecería mucho