Antoni

Asegúrate de tener activado el acceso al modelo de objetos de proyectos VBA:
 

Te dejo resuelta una lista, el resto, por asociación, no deberías tener problemas.
Private Sub CMBIngresaAutor_Click() With Sheets("Listas") If Not Trim(TXTAutor) = "" Then .Range("B" & Rows.Count).End(xlUp).Offset(1) = TXTAutor Else Beep End If .Range("B7").CurrentRegion.Sort Key1:=.Columns("B"), Header:=xlYes 'Reordena la lista CMBLimpiaAutor_Click End With End Sub Private Sub CMBLimpiaAutor_Click() TXTAutor = "" End Sub  

Te dejo tus macros algo más reducidas.
Sustitúyelas por estas:
Asignar macro a los círculos, debes ejecutarla una sola vez:
Sub AsignarMacro() 'Asigna la macro Ovalos a todas las formas Dim s As Shape For Each s In ActiveSheet.Shapes If s.Name Like "Flotante*" Then s.OnAction = "Sheet3.Ovalos" Next End Sub Posicionar círculos:
Private Sub Worksheet_SelectionChange(ByVal Target As Range): On Error Resume Next 'Procedimiento para ubicar los ovalos Const xTop As Integer = 40 Const xLeft As Integer = 50 Dim x As Integer, y As Integer, s As Shape For Each s In ActiveSheet.Shapes If s.Name Like "Flotante*" Then y = Mid(s.Name, 13) s.Top = ActiveCell.Top + xTop * x s.Left = ActiveCell.Left + ((1 - (y Mod 2)) + 1) * xLeft If y Mod 2 = 0 Then x = x + 1 End If Next Exit Sub End Sub Inicializar círculos al activar la hoja:
Private Sub Worksheet_Activate(): On Error Resume Next 'Cambia las formas de color a verde al activar la hoja Dim s As Shape Application.ScreenUpdating = False For Each s In ActiveSheet.Shapes If s.Name Like "Flotante*" Then s.Fill.ForeColor.RGB = vbGreen Next End Sub Acciones al pulsar sobre los circulos:
Sub Ovalos(): On Error Resume Next 'Cambio de color shapes (formas) Application.ScreenUpdating = False y = Mid(Application.Caller, 13) Select Case ActiveSheet.Shapes(Application.Caller).Fill.ForeColor.RGB Case vbGreen ActiveSheet.Shapes(Application.Caller).Fill.ForeColor.RGB = vbYellow MsgBox "Acción 1, Botón " & y, vbInformation Case vbYellow ActiveSheet.Shapes(Application.Caller).Fill.ForeColor.RGB = vbRed MsgBox "Acción 2 Botón " & y, vbInformation Case vbRed ActiveSheet.Shapes(Application.Caller).Fill.ForeColor.RGB = vbGreen MsgBox "Acción 3 Botón " & y, vbInformation End Select End Sub  
Botones Flotantes.xlsb

Sub GenerarAño() Application.ScreenUpdating = False año = InputBox("Indique el año") inicio = CDate("01/01/" & año) fin = CDate("31/12/" & año) For fecha = inicio To fin Sheets(1).Copy After:=Sheets(Sheets.Count) Sheets(Sheets.Count).Name = Replace(fecha, "/", "-") Next End Sub  

Si las fechas están en A1 y B1, en C1 pon:
=A1 - B1
y a C1 le das formato personalizado: 
[H]:mm:ss

He modificado las macros para que el mismo botón sirva para combinar/descombinar las fechas de forma alternativa.
En cuanto al mensaje, debes tener en cuenta que cuando combinas celdas que contienen datos, solo se conservan los de la primera celda, de ahí el aviso.
No ocurre así en la macro ya que esto se ha tenido en cuenta y se conservan los datos de todas las celdas dentro de la celda combinada.
Formato Genérico GANTT.xlsm

Esto ha estado muy fácil, a ver si e inventas una chorrada de las tuyas para entretenerme. 🤣
MTop.xlsm

Otra forma
Sub EncabezadoArrayII() Dim MyArray As Variant MyArray = Range("A1", Cells(1, Columns.Count).End(xlToLeft)) End Sub En este caso el array es de 2 dimensiones por lo que te has de referir a un elemento así:
MyArray(1, c) siendo c el  número de columna.
En cualquier caso, puede que el array sea innecesario, basta con recorrer la fila 1 con:
For y = 1 To Cells(1, Columns.Count).End(xlToLeft).Column ... ... Next  

Con lo cual llegamos a la conclusión que este tipo de protecciones no sirven para nada. 😒

Prueba a ver si es esto lo que buscas:
Sub Prueba_Ytb_2() Dim FileToOpen As Variant Dim OpenBook As Workbook Application.ScreenUpdating = False FileToOpen = Application.GetOpenFilename(Title:="Seleccionar archivo", FileFilter:="Excel Files(*.xls*),*xls*") If FileToOpen <> False Then Set OpenBook = Application.Workbooks.Open(FileToOpen) OpenBook.Sheets(7).Range("C6:K" & OpenBook.Sheets(7).Range("C" & Rows.count).End(xlUp).Row).Copy ThisWorkbook.Worksheets("Hoja1").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues OpenBook.Close End If Application.ScreenUpdating = True End Sub  

Prueba así a ver si te vale:
Private Sub CargarLista() Dim x As Long, Nombre As Range CmbID.Clear For x = 28 To Hoja4.Range("E28").End(xlDown).Row CmbID.AddItem Hoja4.Range("E" & x) Set Nombre = Hoja2.Columns("A").Find(Hoja4.Range("E" & x), , , xlWhole) If Not Nombre Is Nothing Then CmbID.List(CmbID.ListCount - 1, 1) = UCase(Nombre.Offset(, 1)) '<------ CmbID.List(CmbID.ListCount - 1, 2) = Hoja4.Range("F" & x).Text Next TxtTotalR.Text = FormatNumber(Hoja4.Range("F26"), 2) For x = 0 To CmbID.ListCount - 1 If CmbID.List(x, 2) = "" Then CmbID.ListIndex = x Exit For End If Next End Sub  

Esta macro convierte el cuadrante de turnos en formato tabla de BD.
Válida para cualquier mes y número de trabajadores.
Sub aBaseDeDatos() Application.ScreenUpdating = False With Sheets("DeCuaABase") .Range("A8").CurrentRegion.Offset(1).ClearContents fila = 8 For y = .Range("S9").Column To .Cells(8, Columns.Count).End(xlToLeft).Column For x = 8 To .Range("R" & Rows.Count).End(xlUp).Row fila = fila + 1 .Range("A" & fila) = .Cells(x, 17) .Range("B" & fila) = .Cells(6, y) .Range("C" & fila) = .Cells(x, 18) .Range("D" & fila) = .Cells(x, y) Next Next End With Application.ScreenUpdating = True End Sub  

Se supone que el dato buscado es una fecha, prueba así:
Me.LblVence.Caption = Format(Application.WorksheetFunction.VLookup(Me.CmbNTarjeta.Text, Hoja5.Range("I:K"), 3, 0), "mm/yy")  

No se si lo he entendido, si no es así, tendrás que subir el archivo y poner un ejemplo de lo que quieres.
Public Sub enviar_datos() Application.ScreenUpdating = False Dim celda As Range With Sheets("TABLA_DATOS") For Each celda In Sheets("PLANTILLA").Range("E7:E34") If Not celda = 0 Then .Range("A2").EntireRow.Insert .Range("A2") = Sheets("PLANTILLA").Range("D4") .Range("B2") = Sheets("PLANTILLA").Range("F3") .Range("C2") = Sheets("PLANTILLA").Range("I3") .Range("D2") = Sheets("PLANTILLA").Range("I4") .Range("E2") = Sheets("PLANTILLA").Cells(celda.Row, "E") .Range("F2") = Sheets("PLANTILLA").Cells(celda.Row, "D") .Range("G2") = Sheets("PLANTILLA").Cells(celda.Row, "C") .Range("H2") = Sheets("PLANTILLA").Cells(celda.Row, "B") .Range("I2") = Sheets("PLANTILLA").Cells(celda.Row, "A") End If Next End With Application.ScreenUpdating = True End Sub  

Sobra un espacio en Range("A1:A ", prueba así:
For Each archivo In Hoja4.Range("A1:A" & Hoja4.Range("A" & Rows.Count).End(xlUp).Row) .Attachments.Add archivo.Value, 1 Next  

Tranquila, nos ha pasado a todos 😂;
......
.......
evalua el tipo de registro si es huellas o fecas---------------------
    hD.Cells(uf, 10).Value = celda.Offset(0, 26)
    hD.Cells(uf, 23).Value = celda.Offset(0, 42)
    hD.Cells(uf, 12).Value = celda.Offset(0, 43)
   uf =uf +1
  End If
 
Next celda

Sería algo así:
With Sheets("CHECKIN") filaedit = 25 For i = 0 To UserForm1.ListBox2.ListCount - 1 .Cells(filaedit, "a") = UserForm1.ListBox2.List(i, 0) .Cells(filaedit, "o") = UserForm1.ListBox2.List(i, 1) .Cells(filaedit, "t") = UserForm1.ListBox2.List(i, 2) .Cells(filaedit, "z") = UserForm1.ListBox2.List(i, 3) filaedit = filaedit + 1 Next i End With  

Ha sido más sencillo de lo previsto.
Consultar Notificaciones.xlsm

Abre el adjunto y pulsa sobre cualquiera de las opciones de la hoja Categoria.
Estas son las macros:
Sub FiltroB(): Filtro "B- Menos de $1.000": End Sub Sub FiltroC(): Filtro "C- De $1.000 a $5.000": End Sub Sub FiltroD(): Filtro "D- De $5.000 a $15.000": End Sub Sub FiltroE(): Filtro "E- De $15.000 a $25.000": End Sub Sub FiltroF(): Filtro "F- De $25.000 a $50.000": End Sub Sub FiltroG(): Filtro "G- Más de $50.000": End Sub '------------------------------------------------------- Private Sub Filtro(Categoria As String) Application.ScreenUpdating = False Hoja4.Range("G14:N1600").ClearContents fila = 13 For x = 2 To Hoja1.UsedRange.Rows.Count If Hoja1.Range("C" & x) = Categoria Then fila = fila + 1 Hoja1.Range("A" & x).Resize(1, 9).Copy Hoja4.Range("G" & fila).PasteSpecial xlValues End If Next Application.CutCopyMode = False Hoja4.Activate End Sub  
Pruebas (3).xlsm

Yo he interpretado que se trata de fichaje con entrada y salida y lo que se quiere es saber las horas trabajadas. En definitiva, hay que tratar las filas de 2 en 2, dando por supuesto que la  primera corresponde a la entrada y la segunda a la salida.

Hoja1.Range("D" & Rows.Count).End(xlUp).Row  

SQL = "SELECT SUM(IIF(MOVIMIENTO='ENTRADA',IZQ,IZQ*-1)) AS IZQ, SUM(IIF(MOVIMIENTO='ENTRADA',DER,DER*-1)) AS DER, MODELO FROM BASE GROUP BY MODELO"  

Abre el adjunto y haz doble-click en cualquier celda del rango C9:C20 de la hoja CONSULTAS.
No olvides subir tu archivo en futuras consultas, las imágenes no sirven para probar.
CONSULTAS Y ENTREGAS.xlsm