JSDJSD

'Opción 1 Sub FiltrarSKUPorFecha(): Application.ScreenUpdating = False Dim ultimaFila As Long, fila As Long Dim diccionarioSKU As Object Dim listaEliminar As Object Dim fechaActual As String, fechaSiguiente As String Dim f As Variant With Sheets("Consolidado") ultimaFila = .Cells(.Rows.Count, 1).End(xlUp).Row ' Crear diccionarios para comparar SKU y almacenar filas a eliminar Set diccionarioSKU = CreateObject("Scripting.Dictionary") Set listaEliminar = CreateObject("Scripting.Dictionary") ' Recorrer desde la primera fila hasta la penúltima For fila = 2 To ultimaFila - 1 fechaActual = .Cells(fila, 1).Value fechaSiguiente = .Cells(fila + 1, 1).Value ' Solo comparar la fecha actual con la siguiente (inmediatamente superior) If fechaActual <> fechaSiguiente Then diccionarioSKU.RemoveAll ' Limpiar el diccionario antes de llenarlo ' Guardar los SKU de la fecha siguiente (solo de la siguiente) For f = fila + 1 To ultimaFila If .Cells(f, 1).Value <> fechaSiguiente Then Exit For diccionarioSKU(.Cells(f, 2).Value) = 1 Next f ' Revisar los SKU de la fecha actual y marcar los que deben eliminarse For f = fila To 2 Step -1 If .Cells(f, 1).Value <> fechaActual Then Exit For ' Solo eliminar si el SKU no está en la fecha siguiente If Not diccionarioSKU.exists(.Cells(f, 2).Value) Then listaEliminar(f) = 1 ' Marcar fila para eliminar después End If Next f ' Ya no es necesario seguir buscando después de comparar la primera y la siguiente fecha Exit For End If Next fila ' Eliminar las filas marcadas sin afectar el bucle principal For Each f In listaEliminar.keys .Rows(f).Delete Next End With MsgBox "Completado correctamente.", vbInformation End Sub 'Opción 2 Sub FiltrarSKUPorFecha1(): Application.ScreenUpdating = False Dim ultimaFila As Long, fila As Long Dim listaEliminar As Collection Dim fechaActual As String, fechaSiguiente As String Dim f As Variant, i As Long Dim SKUExiste As Boolean With Sheets("Consolidado") ultimaFila = .Cells(.Rows.Count, 1).End(xlUp).Row ' Inicializar la colección para marcar las filas a eliminar Set listaEliminar = New Collection ' Recorrer desde la primera fila hasta la penúltima For fila = 2 To ultimaFila - 1 fechaActual = .Cells(fila, 1).Value fechaSiguiente = .Cells(fila + 1, 1).Value ' Solo comparar la fecha actual con la siguiente (inmediatamente superior) If fechaActual <> fechaSiguiente Then ' Revisar los SKU de la fecha actual y marcar los que deben eliminarse For f = fila To 2 Step -1 If .Cells(f, 1).Value <> fechaActual Then Exit For ' Comprobar si el SKU está en la fecha siguiente SKUExiste = False For i = fila + 1 To ultimaFila If .Cells(i, 1).Value <> fechaSiguiente Then Exit For If .Cells(i, 2).Value = .Cells(f, 2).Value Then SKUExiste = True Exit For End If Next i ' Si el SKU no se encuentra en la fecha siguiente, marcar para eliminar If Not SKUExiste Then listaEliminar.Add f ' Marcar fila para eliminar después End If Next f ' Ya no es necesario seguir buscando después de comparar la primera y la siguiente fecha Exit For End If Next fila ' Eliminar las filas marcadas sin afectar el bucle principal For Each f In listaEliminar .Rows(f).Delete Next f End With MsgBox "Completado correctamente.", vbInformation End Sub TABLA ELIMINAR.xlsm

Prueba y comenta

Perfecto, mañana lo intento

En el ejemplo que pones como quedaría el resultado esperado?

Si puedes subir el libro mejor, en caso contrario la hoja afectada y la macro

Sube tu archivo

Sube tu archivo

Formulario Registro.xlsm

Prueba y comenta

Si nadie te contesta antes, mañana en cuanto tenga un ratillo te lo miro

Cambia el código de tu botón Registrar por este modificado Private Sub CommandButton1_Click() ' Declaramos variables Dim DescripSelec As Variant Dim Codigos As Variant Dim strcodig2 As String Dim intCantidad As Double Dim doublePUnitario As Double Dim intTotal As Double Dim Codigo As Variant ' Capturamos el valor del ComboBox1 Codigo = Me.ComboBox1.Value ' En caso de error On Error Resume Next ' Inicializamos búsqueda de código With Application.WorksheetFunction ' Buscar directamente sin conversión Codigos = .VLookup(Codigo, PRODUCTOS.Range("A:C"), 1, 0) ' Si no se encuentra, mostrar "No encontrado" If IsError(Codigos) Then Codigos = "No encontrado" End If ' Buscar descripción (mismo proceso que el código) DescripSelec = .VLookup(Codigo, PRODUCTOS.Range("A:C"), 2, 0) If IsError(DescripSelec) Then DescripSelec = "No encontrado" End If ' Captura cantidad intCantidad = Me.TextBox1.Value ' Llenamos el ListBox Me.ListBox1.AddItem Codigo ListBox1.List(ListBox1.ListCount - 1, 1) = DescripSelec ListBox1.List(ListBox1.ListCount - 1, 2) = .Text(intCantidad, "#,##0") ' Precio unitario doublePUnitario = Me.TextBox2.Value ListBox1.List(ListBox1.ListCount - 1, 3) = .Text(doublePUnitario, "$#,##0.00;-$#,##0.00") ' Total intTotal = doublePUnitario * intCantidad ListBox1.List(ListBox1.ListCount - 1, 4) = .Text(intTotal, "$#,##0.00;-$#,##0.00") ' Actualización de etiquetas Me.lblProductos = .Text(CInt(Me.lblProductos) + CInt(intCantidad), "#,##0") Me.lblTotal = .Text(CDbl(Me.lblTotal) + CDbl(intTotal), "$#,##0.00;-$#,##0.00") ' Restablecer valores Me.ComboBox1.Value = "" Me.ComboBox1.SetFocus Me.txtConsec = Me.TextBox4.Value Me.TextBox5.Value = Format(CDate(TextBox5.Text), "dd/mm/yyyy") Me.txtFecha = Me.TextBox5.Value End With End Sub

Si nadie contesta ante, mañana te lo miro

La posible solución te la he dado con el archivo anterior, no vi el nuevo que habías subido, pero bueno puedes adaptarlo perfectamente, no es difícil

Esta parte no es difícil, inténtalo y si no lo consigues coméntalo Cemento.xlsm