Descripción de la sección

    • En este módulo aprenderemos a:

      • Separar texto a columnas cuando existe un patrón regular
      • Crear un macro para extraer direcciones de correo electrónico asociados a una imagen que funciona como enlace
      • Eliminar objetos desde el panel de navegación

      No disponible, a menos que: La actividad Video 07 esté calificada como completada 
    • 
' Pasos para usar el código:
' Abre tu archivo de Excel.
' Presiona Alt + F11 para abrir el editor de VBA.
' Inserta un nuevo módulo (Insert > Module).
' Copia y pega el código de este script.
' Cierra el editor de VBA y vuelve a Excel.
' Ejecuta la macro (Alt + F8, selecciona ExtractHyperlinksFromShapes y haz clic en Run).
' Cuando aparezca el cuadro de diálogo, ingresa la letra de la columna donde deseas que se 
' escriban los correos (por ejemplo, E para la columna E).

Sub ExtractHyperlinksFromShapes()
    Dim ws As Worksheet
    Dim wsNumber As Integer
    Dim shp As Shape
    Dim i As Integer
    Dim hyperlinkAddress As String
    Dim columna As String
    Dim columnaNum As Integer
    
    ' Pregunta al usuario en qué hoja de cálculo desea trabajar '
    wsNumber = InputBox("¿En qué hoja del libro deseas extraer los correos? (Introduce el número de hoja, por ejemplo: 1, 2, 3, etc)", "Seleccionar Hoja")
    
    ' Pregunta al usuario en qué columna desea guardar los correos
    columna = InputBox("¿En qué columna deseas guardar los correos? (Introduce la letra de la columna, por ejemplo, D, E, F, etc.)", "Seleccionar Columna")
    
    ' Convierte la letra de la columna en un número '
    columnaNum = Range(columna & "1").Column
    
    ' Cambia el número si la hoja es diferente '
    Set ws = ThisWorkbook.Sheets(wsNumber) 
    ' Comienza en la fila 2 para evitar sobrescribir los encabezados '
    i = 2 
    
    For Each shp In ws.Shapes
        If shp.Type = msoPicture Then
            If shp.Hyperlink.Address <> "" Then
                hyperlinkAddress = shp.Hyperlink.Address
                ' Elimina el prefijo "mailto:" si es que está presente
                If Left(hyperlinkAddress, 7) = "mailto:" Then
                    hyperlinkAddress = Mid(hyperlinkAddress, 8)
                End If
                ' Escribe la dirección de correo en la columna seleccionada '
                ws.Cells(i, columnaNum).Value = hyperlinkAddress 
                i = i + 1
            End If
        End If
    Next shp
End Sub