Consolidar hojas en una sola con una condicion

Necesito de su apoyo:

Tengo 25 a más hojas las cuales quisiera consolidar en una hoja ( el formato se mantiene de la data de todas las hojas)

La columna C Y D deberia tener una condion (Si es C=0 y D=0 se eliminala fila)

La macro que tengo copia todas las hojas( CONSOLIDA) y luego elimina las filas que tengan 0 Y 0.

El problema esta que supero las líneas (1048576 max de líneas en excel 2010)

Por cada hoja que tengo tiene 60000 lineas y 60000*25 hojas =1500000 superando la capacidad.

¿Qué quisiera que haga?

Es que primero copie hoja 1 elimina según condición, luego hoja 2 elimine según condición así sucesivamente.

Al eliminar todos los 0 y 0 solo tendría como máximo en líneas 30000.

Public NUmFilasTotales As Long

Sub Copiar()
Dim Progreso As New frm_lcf_ProgressBar
Dim Inicio As Integer
Dim TituloVentana As String
Dim FinBarra As Long
Dim i As Long
Inicio = 2
TituloVentana = "Cesar"

For Each hoja In ActiveWorkbook.Sheets
If hoja.Name = "Resumen" Then hoja.Delete
Next

Sheets.Add before:=Sheets(1)
ActiveSheet.Name = "Resumen"

For x = 2 To Sheets.Count
Sheets(x).Select
Range("a3:o" & Range("a1048576").End(xlUp).Row).Copy
Sheets("Resumen").Range("a1048576").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
Next

Sheets("Resumen").Select
NUmFilasTotales = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
FinBarra = NUmFilasTotales
Progreso.Initialize FinBarra, Inicio, TituloVentana
Progreso.Show 0

For x = 1 To NUmFilasTotales
If (Cells(x, 3).Value = 0 And Cells(x, 3).Value <> "") And (Cells(x, 4).Value = 0 And Cells(x, 3).Value <> "") Then
Cells(x, 3).Select
Rows(x).EntireRow.Delete
If x > 1 Then x = x - 1
Progreso.Increase 1
End If
Next
MsgBox "La Barra de Progreso indica el % de Registros eliminados!", vbExclamation
Cells(2, 1).Select
Unload Progreso
End Sub

1 Respuesta

Respuesta
1

Te cambio la macro.

Lo que hace es filtrar la información de cada hoja y la copia.

Solamente cambia el 2 en esta línea por le número de fila donde tienes los encabezados.

Fila = 2 'fila encabezados

Hice la prueba para 10 hojas con 68,000 registros cada una, un total de 680,000 registros y los filtro y copio en 5 segundos.

Sub Copiar_Filas()
'Por Dante Amor
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.StatusBar = False
    On Error Resume Next
    Sheets("Resumen").Delete
    On Error GoTo 0
    '
    Set h1 = Sheets.Add(before:=Sheets(1))
    h1.Name = "Resumen"
    fila = 2                    'fila encabezados
    '
    h1.Range("R1").Value = Sheets(2).Range("C" & fila).Value
    h1.Range("S1").Value = Sheets(2).Range("C" & fila).Value
    h1.Range("T1").Value = Sheets(2).Range("D" & fila).Value
    h1.Range("U1").Value = Sheets(2).Range("D" & fila).Value
    '
    h1.Range("R2").Value = "<>0"
    h1.Range("S2").Value = "<>"
    h1.Range("T2").Value = "<>0"
    h1.Range("U2").Value = "<>"
    '
    una = True
    For i = 2 To Sheets.Count
        Application.StatusBar = "Copiando hoja : " & i
        If Sheets(i).FilterMode Then Sheets(i).ShowAllData
        u1 = h1.Range("A" & Rows.Count).End(xlUp).Row + 1
        Sheets(i).Range("A" & fila & ":O" & Sheets(i).Range("A" & Rows.Count).End(xlUp).Row).AdvancedFilter _
            Action:=xlFilterCopy, CriteriaRange:=h1.Range("R1:U2"), CopyToRange:=h1.Range("A" & u1), Unique:=False
        If una = False Then h1.Rows(u1).Delete
        una = False
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.StatusBar = False
    MsgBox "Fin"
End Sub

Nota: en la parte inferior izquierda de la pantalla de excel aparece el número de hoja copiada.


'.[Sal u dos. Dante Amor. No olvides valorar la respuesta. 

¡Gracias! Excelente !!funciona muy bien...

No me copia el último registro el que está en la fila  1048576

Le hice una prueba en una hoja poniendo un dato el la última fila 

¿Tienes información en el último registro de la hoja?

Mencionaste que tenías 60,000 líneas por hoja.

Ese detalle incluso pasa con tu macro.

Agrega una condición en la macro, si la última fila tiene datos, entonces que filtre desde el encabezado hasta la última fila de excel, por ejemplo:

if sheets(i).range("A" & rows.count).value <> "" then
   uf = rows.count
else 
   uf = Sheets(i).Range("A" & Rows.Count).End(xlUp).Row      
end if
Sheets(i).Range("A" & fila & ":O" & uf).AdvancedFilter _
            Action:=xlFilterCopy, CriteriaRange:=h1.Range("R1:U2"), CopyToRange:=h1.Range("A" & u1), Unique:=False

Si tienes hojas con información hasta la última fila de excel, es muy probable que la hoja "resumen" se llene.

Cómo lo integro a la macro ??

Me podrías copiar el código final...

¿Tienes información en el último registro de la hoja?

Mencionaste que tenías 60,000 líneas por hoja.

Eh descargado una nueva data y fluctúa entre 60000 registros y 75000 por eso me gustaría que haga el filtro por todos los registros totales de una hoja.(para evitar un error)

¿Tienes información en el último registro de la hoja?

¿Ya probaste para las 75,000 o para un millón?

La macro funciona hasta la línea 1048575 sin problemas, por eso te pregunto si vas a tener datos en la última fila 1048576


Cambia en la macro esta línea por las nuevas líneas que te envié

        Sheets(i).Range("A" & fila & ":O" & Sheets(i).Range("A" & Rows.Count).End(xlUp).Row).AdvancedFilter _
            Action:=xlFilterCopy, CriteriaRange:=h1.Range("R1:U2"), CopyToRange:=h1.Range("A" & u1), Unique:=False

SII!!! Lo probé con 1 millón y si lo hace está muy bien. Pero la condición no lo está cumpliendo.

0 y 0 elimina

0 y 1 data de interés

1 y 0 data de interés

1 y 1 data de interés

-1 -1 data de interés 

Estos pueden ser números diversos ( 1 es como dato ejemplo)

Solo si es 0 y 0 elimina.

Me está eliminando 1y 0 - 0 y 1

Va la macro actualizada

Sub Copiar_Filas()
'Por Dante Amor
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.StatusBar = False
    On Error Resume Next
    Sheets("Resumen").Delete
    On Error GoTo 0
    '
    Set h1 = Sheets.Add(before:=Sheets(1))
    h1.Name = "Resumen"
    fila = 2                    'fila encabezados
    '
    h1.Range("R1").Value = Sheets(2).Range("C" & fila).Value
    h1.Range("S1").Value = Sheets(2).Range("C" & fila).Value
    h1.Range("T1").Value = Sheets(2).Range("D" & fila).Value
    h1.Range("U1").Value = Sheets(2).Range("D" & fila).Value
    '
    h1.Range("R2").Formula = "=""<>0"""
    h1.Range("S2").Formula = "=""<>"""
    h1.Range("T3").Formula = "=""<>0"""
    h1.Range("U3").Formula = "=""<>"""
    '
    una = True
    For i = 2 To Sheets.Count
        Application.StatusBar = "Copiando hoja : " & i
        If Sheets(i).FilterMode Then Sheets(i).ShowAllData
        u1 = h1.Range("A" & Rows.Count).End(xlUp).Row + 1
        If Sheets(i).Range("A" & Rows.Count).Value <> "" Then
           uf = Rows.Count
        Else
           uf = Sheets(i).Range("A" & Rows.Count).End(xlUp).Row
        End If
        Sheets(i).Range("A" & fila & ":O" & uf).AdvancedFilter _
            Action:=xlFilterCopy, CriteriaRange:=h1.Range("R1:U3"), CopyToRange:=h1.Range("A" & u1), Unique:=False
        If una = False Then h1.Rows(u1).Delete
        una = False
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.StatusBar = False
    MsgBox "Fin"
End Sub

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas