JSDJSD

Ejecuta la macro con Ctrl+f Seguimientos - copia (1).xlsm

Cambia tu macro del modulo1 por esta Sub FUSION(): Application.DisplayAlerts = False Dim hoja As Worksheet Dim cabecera As Boolean Dim ufh2 As Long On Error Resume Next: Sheets("FUSION").Delete: On Error GoTo 0 ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count) ActiveSheet.Name = "FUSION" Sheets("FUSION").Range("A2").Resize(Sheets("FUSION").Rows.Count - 1).Offset(0, 0).Delete cabecera = False For Each hoja In Sheets If hoja.Name Like "Seguimiento" & "*" Then ufh2 = Sheets("FUSION").Range("E" & Sheets("FUSION").Rows.Count).End(xlUp).Row + 1 If Not cabecera Then hoja.Range("A1:E1").Copy Destination:=Sheets("FUSION").Range("A1") cabecera = True End If With hoja.Range("A1").CurrentRegion .AutoFilter 5, Criteria1:="<>" .Offset(1).Resize(.Rows.Count - 1, .Columns.Count).SpecialCells(xlCellTypeVisible).Copy Sheets("FUSION").Range("A" & ufh2) .AutoFilter End With End If Next Sheets("FUSION").Range("A:E").Columns.AutoFit MsgBox "Los datos se han actualizado correctamente en la hoja 'FUSION'." End Sub Prueba y comenta

Mañana te lo miro

Sube tus archivos

Private Sub CommandButton1_Click() Hoja1.Range("A2").Resize(Hoja1.Rows.Count - 1).Offset(0, 0).Delete For Each hoja In Sheets If hoja.Name Like "Seguimiento" & "*" Then ufh2 = Hoja1.Range("E" & Rows.Count).End(xlUp).Row + 1 With Sheets(hoja.Name).Range("A1").CurrentRegion .AutoFilter 5, Criteria1:="<>" .Offset(1).Resize(.Rows.Count - 1, .Columns.Count).SpecialCells(xlCellTypeVisible).Copy Hoja1.Range("A" & ufh2) .AutoFilter End With End If Next End Sub Seguimientos - copia.xlsm

Prueba y comenta

Prueba fusion.xlsm

A ver si te apañas con esto

Quieres mantener el formato de tabla dinámica o te da igual como rango de datos ?

Las filas en blanco las quieres conservar o solamente las que tienen datos ? cuando digo las filas en blanco me refiero a las que tienen datos solamente en la columna A

Sube tu archivo y lo intentamos, deja una muestra de como debe quedar la fusión de las misma

Private Sub CommandButton1_Click(): Application.ScreenUpdating = False Dim NewRow As Long If MsgBox("Dar de alta los datos?", vbYesNo + vbExclamation, RegistroMPG) = vbYes Then With ThisWorkbook.Worksheets("Hoja1") NewRow = .Range("A" & Rows.Count).End(xlUp).Row + 1 .Cells(NewRow, 1).Value = Val(Me.txtCons) .Cells(NewRow, 2).Value = Me.TextCliente .Cells(NewRow, 3).Value = Me.txtDocs .Cells(NewRow, 4).Value = Me.txtTipoDocs .Cells(NewRow, 5).Value = Me.txtNoDocs .Cells(NewRow, 6).Value = Me.TextFechaEmision .Cells(NewRow, 7).Value = Me.TextVigencia .Cells(NewRow, 8).Value = Me.TextCopCert .Cells(NewRow, 9).Value = Me.TextFechaCert .Cells(NewRow, 10).Value = Me.TextFabric .Cells(NewRow, 11).Value = Me.TextProductos .Cells(NewRow, 12).Value = Me.TextFechaReg .Cells(NewRow, 13).Value = Me.TextReferencia .Cells(NewRow, 14).Value = Me.TextObserv .UsedRange.Sort Key1:=.Columns("A"), Order1:=xlDescending, Header:=xlNo End With MsgBox "Alta exitosa.", vbInformation, RegistroMPG Unload Me End If End Sub Ingreso Por user Form.xlsm

Te dejo otra opción

Sube tu archivo

Sube tu archivo con el formulario

hoy.xlsm

Según lo que aportas, se me ocurre algo como esto

Private Sub txtFecha_Change() With Hoja3.Range("A1").CurrentRegion uf = .Range("A" & Rows.Count).End(xlUp).Row .Columns("E:E").NumberFormat = "m/d/yyyy" .AutoFilter 5, txtFecha.Value Hoja1.Range("A1").CurrentRegion.Delete .SpecialCells(12).Copy Hoja1.Range("A1") ListTabla.RowSource = Hoja1.Range("A1"). _ CurrentRegion.Offset(1).Address(, , , 1) .AutoFilter .Columns("E:E").NumberFormat = "m/d/yyyy h:mm" End With End Sub Registro de Entradas y Salidas - copia.xlsm

Prueba y comenta

Vale, te has adelantado por milésimas de segundo

Sube tu archivo y pon un ejemplo de lo que quiere conseguir

Mañana te lo miro

Prueba y comenta Sub SumarEnRangoOptimizado() Dim folderPath As String Dim fileName As String Dim excelApp As Object Dim wb As Object Dim ws As Object Dim rng As Object ' Carpeta que contiene los archivos folderPath = "D:\Carpeta\" ' Deshabilitar actualizaciones de pantalla y cálculos automáticos Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' Crear una instancia de Excel Application On Error Resume Next ' Manejar errores al intentar conectar con una instancia existente Set excelApp = GetObject(, "Excel.Application") On Error GoTo 0 ' Reactivar la gestión de errores normales si no se encuentra ninguna instancia existente If excelApp Is Nothing Then Set excelApp = CreateObject("Excel.Application") excelApp.DisplayAlerts = False ' Desactivar las alertas End If ' Iterar sobre los archivos en la carpeta fileName = Dir(folderPath & "\*.xlsx") Do While fileName <> "" ' Abrir el archivo Set wb = excelApp.Workbooks.Open(folderPath & "\" & fileName) Set ws = wb.Sheets(1) ' Primera hoja de trabajo ' Aplicar la fórmula directamente en el rango With ws Set rng = .Range("A3239:D3850") With rng .Formula = "=A$3238 + (ROW()-3238)" .Value = .Value ' Convertir las fórmulas en valores End With End With ' Cerrar el archivo sin guardar cambios wb.Close SaveChanges:=True ' Obtener el siguiente archivo en la carpeta fileName = Dir Loop ' Cerrar la instancia de Excel Application excelApp.Quit Set excelApp = Nothing ' Habilitar actualizaciones de pantalla y cálculos automáticos Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "La operación se ha completado en todos los archivos de la carpeta.", vbInformation End Sub

Sub BuscarCoincidencias() Dim hoja1 As Worksheet Dim hoja2 As Worksheet Dim rango As Range Dim celda As Range Dim buscado As Variant Dim contador As Integer Dim suma As Double Dim celdaBuscar As Range Dim ultimaFila As Long Dim valoresBuscados() As Variant Dim encontrado As Boolean Set hoja1 = ThisWorkbook.Sheets("Hoja1") Set hoja2 = ThisWorkbook.Sheets("Hoja2") Set celdaBuscar = hoja1.Range("A3") ultimaFila = hoja1.Cells(hoja1.Rows.Count, celdaBuscar.Column).End(xlUp).Row ReDim valoresBuscados(0 To 0) For i = celdaBuscar.Row To ultimaFila buscado = hoja1.Cells(i, celdaBuscar.Column).Value encontrado = False For Each valor In valoresBuscados If valor = buscado Then encontrado = True Exit For End If Next valor If encontrado Then GoTo SiguienteValor contador = 0 suma = 0 For j = i To ultimaFila If hoja1.Cells(j, celdaBuscar.Column).Value = buscado Then contador = contador + 1 suma = suma + hoja1.Cells(j, celdaBuscar.Column + 9).Value End If Next j If contador >= 5 Then Set rango = hoja2.Columns("C:C").Find(What:=buscado, LookAt:=xlWhole) If Not rango Is Nothing Then If buscado >= 400 Then hoja2.Cells(rango.Row, "F").Value = suma Else hoja2.Cells(rango.Row, "E").Value = suma End If End If Else Set rango = hoja2.Columns("C:C").Find(What:=buscado, LookAt:=xlWhole) If Not rango Is Nothing Then If buscado >= 400 Then hoja2.Cells(rango.Row, "F").Value = suma Else hoja2.Cells(rango.Row, "E").Value = suma End If End If End If valoresBuscados(UBound(valoresBuscados)) = buscado ReDim Preserve valoresBuscados(0 To UBound(valoresBuscados) + 1) SiguienteValor: Next i hoja2.Range("E5").Value = hoja2.Cells(7, "E").Value - (hoja2.Cells(2, "E").Value + hoja2.Cells(3, "E").Value + hoja2.Cells(4, "E").Value) hoja2.Range("E29").Value = Application.WorksheetFunction.Sum(hoja2.Range("E7:E28")) hoja2.Range("F29").Value = Application.WorksheetFunction.Sum(hoja2.Range("F7:F28")) hoja2.Range("E30").Value = hoja2.Range("E29").Value - hoja2.Range("F29").Value End Sub RESUMEN CARGA LIQUIDACION A SISTEMA.xlsm

Prueba y comenta