JSDJSD

prueba TABLA PROTEGIDA.xlsm tu archivo
 

El archivo
 
Libro27102024.xlsm

Prueba y comenta
HHE PRUEBA (3) (1).xlsm

El archivo
HHE PRUEBA (3).xlsm

Private Sub ComBanco_Change() Dim hojabuscada As String Dim ultFila As Long Dim ultCol As Long hojabuscada = ComBanco With Sheets(hojabuscada) ultFila = .Cells(.Rows.Count, 1).End(xlUp).Row ultCol = .Cells(6, .Columns.Count).End(xlToLeft).Column LstDiario.RowSource = .Range(.Cells(6, 1), .Cells(ultFila, ultCol)).Address(External:=True) End With End Sub El saldo inicial no se si quieres que se muestre, en caso contrario modifica la macro, simplemente cambia en la dos ultimas líneas del bloque with el 6 por el 7
Para Foro.xlsm

Sub ConsolidarSeguimientos(): Application.ScreenUpdating = False primeraCopia = True On Error Resume Next Set destino = Sheets("Seguimiento_Anual") If destino Is Nothing Then Set destino = Sheets.Add destino.Name = "Seguimiento_Anual" Else destino.Cells.Clear End If On Error GoTo 0 For Each ws In ThisWorkbook.Worksheets If ws.Name Like "Seguimiento_*" And ws.Name <> "Seguimiento_Anual" Then If Application.WorksheetFunction.CountA(destino.Cells) = 0 Then ultimaFila = 1 Else ultimaFila = destino.Cells(destino.Rows.Count, "A").End(xlUp).Row + 1 End If If primeraCopia Then ws.UsedRange.Copy Destination:=destino.Cells(ultimaFila, 1) primeraCopia = False Else ws.UsedRange.Offset(1, 0).Resize(ws.UsedRange.Rows.Count - 1).Copy _ Destination:=destino.Cells(ultimaFila, 1) End If End If Next ws ultimaFila = destino.Cells(destino.Rows.Count, "A").End(xlUp).Row Dim i As Long For i = ultimaFila To 2 Step -1 If IsEmpty(destino.Cells(i, 3)) Then destino.Rows(i).Delete End If Next i With destino.Sort .SortFields.Clear .SortFields.Add Key:=destino.Range("A2:A" & ultimaFila), Order:=xlAscending .SortFields.Add Key:=destino.Range("B2:B" & ultimaFila), Order:=xlAscending .SetRange destino.Range("A1").CurrentRegion .Header = xlYes .Apply End With destino.UsedRange.Columns.AutoFit MsgBox "Consolidación completada.", vbInformation End Sub  
Organización Formaciones Centro (1).xlsm

Sub CombinarCeldaCyD(): Application.DisplayAlerts = False If Selection Is Nothing Then Exit Sub Set Celda = Selection If Celda.Column <> 3 Then Exit Sub TextoC = Celda.Value TextoD = Celda.Offset(0, 1).Value TextoCombinado = TextoC & " " & TextoD Set RangoACombinar = Range(Celda, Celda.Offset(0, 1)) With RangoACombinar .Merge .Value = TextoCombinado End With End Sub  

tu archivo
PRUEBA.xlsm

stock ALMACEN MMPP 2024 rev.1001 (1).xlsm

Sub RecorrerRangoC() Set hoja = ActiveSheet Set rango = hoja.Range("C2:C" & hoja.Cells(hoja.Rows.Count, "C").End(xlUp).Row) If rango.Cells.Count = 0 Then MsgBox "No hay datos en la columna C.", vbExclamation Exit Sub End If For Each celda In rango.SpecialCells(xlCellTypeVisible) celda.Select Application.Wait Now + TimeValue("00:00:01") Next celda End Sub Prueba y comenta

Ahora mirando veo que ya te han dado solución en el foro amigo

No me queda claro te dejo una prueba a ver si es esto, teniendo en cuenta la jornada laboral de 40 horas semanales si calculamos la primera fila daría como resultado 40 hora y 37 extra, de no ser esto sube un ejemplo de como debería quedar en la primera fila

A ver si te apañas con esto

Sub Macro1() Dim tablaRef As Range Dim UltimaFila As Long Dim UltimaColumna As Long ' Recogemos valores para las variables de UltimaFila y UltimaColumna With Sheets("Hoja1") UltimaFila = .Cells(.Rows.Count, "C").End(xlUp).Row UltimaColumna = .Cells(3, .Columns.Count).End(xlToLeft).Column Set tablaRef = .Range(.Cells(3, 3), .Cells(UltimaFila, UltimaColumna)) End With ' Seleccionamos la tabla de referencias tablaRef.Select End Sub No lo he probado, prueba y comenta

Private Sub Worksheet_Change(ByVal Objetivo As Range) With Hoja1 If Not Intersect(Objetivo, .Range("E3")) Is Nothing Then Application.EnableEvents = False nuevoValor = Objetivo ultimaFila = .Cells(.Rows.Count, "D").End(xlUp).Row For i = 4 To ultimaFila textoActual = .Cells(i, "D") posicionPunto = InStr(1, textoActual, ".") If posicionPunto > 0 Then textoDespuesPunto = Mid(textoActual, posicionPunto + 1) .Cells(i, "D") = nuevoValor & "." & textoDespuesPunto End If nuevoValor = nuevoValor + 1 Next i Application.EnableEvents = True End If End With End Sub  
Cambio automatico de numeros.xlsm

Modificaciones  realizadas respetando siempre al máximo tu código original

Private Sub Worksheet_Change(ByVal Target As Range) Application.ScreenUpdating = False Dim uf As Long If Target.Address = "$H$5" Then uf = Hoja1.Cells(Hoja1.Rows.Count, "J").End(xlUp).Row If uf = 4 Then uf = 5 Hoja1.Range("J5:J" & uf).ClearContents valorSeleccionado = Range("H5").Value With Hoja1.Range("B4").CurrentRegion .AutoFilter 2, valorSeleccionado On Error Resume Next .Offset(1, 0).Resize(.Rows.Count - 1) _ .SpecialCells(xlCellTypeVisible).Columns(4).Copy Hoja1.Range("J5") On Error GoTo 0 .AutoFilter End With End If End Sub  
Libro.xlsm

Mañana intento sacar un rato para acabarlo 

Private Sub Worksheet_Calculate() Dim Rango As String Rango = "J23" For i = 1 To ActiveSheet.Shapes.Count ActiveSheet.Shapes(i).Visible = True Next i For i = 1 To ActiveSheet.Shapes.Count If ActiveSheet.Shapes(i).Name = Range(Rango).Text Then ActiveSheet.Shapes(i).Visible = False Exit For End If Next i End Sub  

Prueba y comenta 
Sub copiar_hojamc() Dim actual As Workbook Dim LibroDestino As Workbook Dim nuevaHoja As Worksheet Dim nombre As String Dim ruta As String Set actual = ThisWorkbook nombre = actual.Sheets("Lista").Range("A2").Value ruta = actual.Path On Error Resume Next Set LibroDestino = Workbooks.Open(ruta & "\" & "LibroDestino.xlsx") On Error GoTo 0 If LibroDestino Is Nothing Then Set LibroDestino = Workbooks.Add LibroDestino.SaveAs ruta & "\" & "LibroDestino.xlsx" End If Dim hojaExistente As Boolean hojaExistente = False For Each hoja In LibroDestino.Sheets If hoja.Name = nombre Then hojaExistente = True Exit For End If Next hoja If hojaExistente Then nombre = InputBox("La hoja con el nombre '" & nombre & "' ya existe en el LibroDestino. Por favor, introduce un nuevo nombre:", "Nombre duplicado") End If Set nuevaHoja = LibroDestino.Sheets.Add(After:=LibroDestino.Sheets(LibroDestino.Sheets.Count)) actual.Sheets("Lista").UsedRange.Copy nuevaHoja.Paste nuevaHoja.Name = nombre Application.CutCopyMode = False LibroDestino.Save LibroDestino.Close False actual.Activate MsgBox "El contenido de la hoja Lista se ha copiado al LibroDestino con el nombre " & nombre End Sub  

Ten en cuenta que con el calendario que tienes no te funcionará ya que quieres buscar la fecha actual y el calendario es de 2024, a modo de prueba te he modificado la fecha de 10 de diciembre fecha de hoy y le he puesto del año 2023 para que veas el resultado.

Entonces sería esto lo que necesitas verdad ?