Asistencias

Sub ImagenASiYEliminar()
    Dim ws As Worksheet
    Dim shp As Shape
    Dim celda As Range
    Dim colObjetivo As Long
    Dim i As Long

    Set ws = ActiveSheet
    colObjetivo = 4 ' Columna D

    For i = ws.Shapes.Count To 1 Step -1
        Set shp = ws.Shapes(i)
        If shp.Type = msoPicture Or shp.Type = msoLinkedPicture Then
            Set celda = shp.TopLeftCell
            If celda.Column = colObjetivo Then
                celda.Value = "SI"
            End If
            shp.Delete
        End If
    Next i
    MsgBox "Proceso terminado"
End Sub

Sub ProcesarImagenesEnTodoElLibro()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        ws.Activate
        Call ImagenASiYEliminar
    Next ws
    MsgBox "Proceso terminado en todas las hojas"
End Sub

Bitácora

Teams

Option Explicit

Public Sub CruzarNombres_EC_vs_Plantilla()
    Dim wsEC As Worksheet, wsPl As Worksheet
    Dim lastEC As Long, lastPl As Long
    Dim dict As Object
    Dim i As Long
    Dim key As String, nombre As String
    Dim valB As Variant

    Set wsEC = ThisWorkbook.Worksheets("EC")
    Set wsPl = ThisWorkbook.Worksheets("Plantilla")

    lastEC = wsEC.Cells(wsEC.Rows.Count, "C").End(xlUp).Row
    lastPl = wsPl.Cells(wsPl.Rows.Count, "C").End(xlUp).Row

    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare

    ' 1) Indexar Plantilla: key(normalizada de C) -> valor B
    For i = 2 To lastPl
        nombre = wsPl.Cells(i, "C").Value2
        If Len(Trim$(nombre)) > 0 Then
            key = CanonicalName(nombre)
            If Not dict.Exists(key) Then
                dict.Add key, wsPl.Cells(i, "B").Value2
            End If
        End If
    Next i

    ' 2) Buscar para cada fila en EC y escribir resultado en B
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    For i = 2 To lastEC
        nombre = wsEC.Cells(i, "C").Value2
        If Len(Trim$(nombre)) = 0 Then
            wsEC.Cells(i, "B").Value = ""
        Else
            key = CanonicalName(nombre)
            If dict.Exists(key) Then
                valB = dict(key)
                wsEC.Cells(i, "B").Value = valB
            Else
                wsEC.Cells(i, "B").Value = ""  ' o "No encontrado"
            End If
        End If
    Next i

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

' Convierte "Zuria Renata Luciano Diaz" y "LUCIANO DIAZ ZURIA RENATA"
' en la misma llave: "DIAZ|LUCIANO|RENATA|ZURIA"
Private Function CanonicalName(ByVal s As String) As String
    Dim t As String, arr As Variant, i As Long
    Dim words() As String, n As Long

    t = UCase$(Trim$(s))
    t = Replace(t, vbCr, " ")
    t = Replace(t, vbLf, " ")
    t = RemoveAccents(t)

    ' Reemplaza separadores raros por espacio
    t = Replace(t, ".", " ")
    t = Replace(t, ",", " ")
    t = Replace(t, "-", " ")
    t = Replace(t, "_", " ")

    ' Quitar dobles espacios
    Do While InStr(t, "  ") > 0
        t = Replace(t, "  ", " ")
    Loop

    If Len(t) = 0 Then
        CanonicalName = ""
        Exit Function
    End If

    arr = Split(t, " ")

    ' Filtra palabras vac’as y (opcional) ignora part’culas comunes
    ReDim words(0 To UBound(arr))
    n = 0
    For i = LBound(arr) To UBound(arr)
        If Len(arr(i)) > 0 Then
            If Not IsStopWord(arr(i)) Then
                words(n) = arr(i)
                n = n + 1
            End If
        End If
    Next i

    If n = 0 Then
        CanonicalName = ""
        Exit Function
    End If

    ReDim Preserve words(0 To n - 1)
    QuickSort words, LBound(words), UBound(words)

    CanonicalName = Join(words, "|")
End Function

' Ignorar part’culas (ajœstalo si quieres que cuenten)
Private Function IsStopWord(ByVal w As String) As Boolean
    Select Case w
        Case "DE", "DEL", "LA", "LAS", "LOS", "Y"
            IsStopWord = True
        Case Else
            IsStopWord = False
    End Select
End Function

' Quitar acentos b‡sicos
Private Function RemoveAccents(ByVal s As String) As String
    Dim a As Variant, b As Variant, i As Long
    a = Array("ç", "Ë", "€", "å", "Ì", "ƒ", "é", "è", "æ", "ê", "í", "ì", "ë", "î", "ñ", "…", "ï", "Í", "ò", "ô", "†", "ó", "„")
    b = Array("A", "A", "A", "A", "A", "E", "E", "E", "E", "I", "I", "I", "I", "O", "O", "O", "O", "O", "U", "U", "U", "U", "N")
    For i = LBound(a) To UBound(a)
        s = Replace(s, a(i), b(i))
    Next i
    RemoveAccents = s
End Function

' QuickSort para ordenar palabras
Private Sub QuickSort(ByRef arr() As String, ByVal first As Long, ByVal last As Long)
    Dim i As Long, j As Long
    Dim pivot As String, tmp As String

    i = first
    j = last
    pivot = arr((first + last) \ 2)

    Do While i <= j
        Do While arr(i) < pivot
            i = i + 1
        Loop
        Do While arr(j) > pivot
            j = j - 1
        Loop
        If i <= j Then
            tmp = arr(i)
            arr(i) = arr(j)
            arr(j) = tmp
            i = i + 1
            j = j - 1
        End If
    Loop

    If first < j Then QuickSort arr, first, j
    If i < last Then QuickSort arr, i, last
End Sub

Files

Sub ImportarHojaAsistencia()

    Dim wbDestino As Workbook
    Dim wbOrigen As Workbook
    Dim wsOrigen As Worksheet
    Dim nombreHoja As String
    Dim ruta As String

    Set wbDestino = ThisWorkbook

    ' Pedir nombre de la hoja
    nombreHoja = InputBox("Escribe el nombre de la hoja que quieres importar:", "Importar hoja")

    If nombreHoja = "" Then Exit Sub

    ' Ruta del archivo Asistencia
    ruta = wbDestino.Path & Application.PathSeparator & "Asistencia.xlsm"

    ' Abrir archivo origen
    On Error Resume Next
    Set wbOrigen = Workbooks.Open(ruta)
    On Error GoTo 0

    If wbOrigen Is Nothing Then
        MsgBox "No se pudo abrir el archivo Asistencia.xlsm", vbCritical
        Exit Sub
    End If

    ' Buscar hoja
    On Error Resume Next
    Set wsOrigen = wbOrigen.Worksheets(nombreHoja)
    On Error GoTo 0

    If wsOrigen Is Nothing Then
        MsgBox "La hoja no existe en Asistencia.xlsm", vbExclamation
        wbOrigen.Close False
        Exit Sub
    End If

    ' Eliminar hoja A si ya existe
    Application.DisplayAlerts = False
    On Error Resume Next
    wbDestino.Worksheets("A").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    ' Copiar hoja
    wsOrigen.Copy After:=wbDestino.Sheets(wbDestino.Sheets.Count)

    ' Renombrar hoja copiada
    wbDestino.ActiveSheet.Name = "A"

    ' Cerrar archivo origen
    wbOrigen.Close False

    MsgBox "Hoja importada correctamente."

End Sub

Sub ExportarPrimeraHojaSinFormulas_ConImagenes()

    Dim wbOrigen As Workbook
    Dim wbNuevo As Workbook
    Dim wsNueva As Worksheet
    Dim ruta As String
    Dim nombreArchivo As String

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set wbOrigen = ThisWorkbook

    ' Copiar la primera hoja completa a un libro nuevo
    wbOrigen.Worksheets(1).Copy
    Set wbNuevo = ActiveWorkbook
    Set wsNueva = wbNuevo.Worksheets(1)

    ' Convertir fórmulas a valores, manteniendo formato e imágenes
    wsNueva.UsedRange.Value = wsNueva.UsedRange.Value

    ' Crear nombre único con fecha y hora
    nombreArchivo = "Export_" & Format(Now, "yyyymmdd_hhmmss") & ".xlsx"

    ruta = wbOrigen.Path & Application.PathSeparator & nombreArchivo

    wbNuevo.SaveAs Filename:=ruta, FileFormat:=xlOpenXMLWorkbook

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

    MsgBox "Archivo creado: " & ruta

End Sub