Tema de rendimiento "no suficiente memoria" Macro vba Excel - Datos de parsing

He construido un código que debe analizar los datos de acuerdo con un valor único y luego crear una nueva hoja de trabajo para cada valor único. Mi tabla inicial tiene 10 Columnas y alrededor de 25K filas. El código funciona bien para hasta 8500 filas. Arriba, recibo el mensaje de error

no suficiente memoria, etc...

Excel 64bits no se puede instalar en nuestras máquinas de trabajo... ¿Alguna idea para un trabajo? Sólo necesito este código para correr en menos de 3 horas y será una gran victoria! ¡Gracias!

Sub Split_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim OutPut As Integer



 'This macro splits data into multiple worksheets based on the variables on a column found in Excel.
 'An InputBox asks you which columns you'd like to filter by, and it just creates these worksheets.

Application.ScreenUpdating = False
vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="10", Type:=1)
Set ws = Worksheets("Import") 'change worhseet name when necessary
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:J14"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 3 To lr
    On Error Resume Next
    If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
        ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
    End If
Next
Application.ScreenUpdating = False
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear

For i = 3 To UBound(myarr)
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
        Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
    Else
        Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
    End If
    ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
    Sheets(myarr(i) & "").Columns.AutoFit

Next

ws.AutoFilterMode = False
ws.Activate
Sheets("Instructions").Select

OutPut = MsgBox("Data successfully parsed", vbInformation, "Confirmation")
End Sub

Pregunta hecha hace 3 años, 5 meses, 0 días - Por bytebison

3 Respuestas:

  • Esto funciona para mí:

    EDIT - actualizado para la cuenta de la fila de encabezados

    Sub Split_data()
    
    Const NUM_HEADER_ROWS As Long = 14
    Dim ws As Worksheet, wb As Workbook, dict As Object
    
    Dim tbl As Range, rngHeaders As Range, arr, r As Long, k, vcol, v
    Dim rngData As Range
    
    Set wb = ActiveWorkbook 'or Thisworkbook
    Set ws = Worksheets("Import")
    
    Set tbl = ws.Range("A1").CurrentRegion        'the whole table
    Set rngHeaders = tbl.Resize(NUM_HEADER_ROWS)  'all the headers
    
    Set rngData = tbl.Offset(NUM_HEADER_ROWS) _
                  .Resize(tbl.Rows.Count - NUM_HEADER_ROWS) 'just the data
    
    vcol = Application.InputBox(prompt:="Which column on '" & ws.Name & _
                                "' would you like to filter by?", _
                                Title:="Filter column", Default:="10", Type:=1)
    
    'collect all the unique values from the selected column
    Set dict = CreateObject("scripting.dictionary")
    arr = ws.Range(ws.Cells(rngData.Rows(1).Row, vcol), _
                   ws.Cells(Rows.Count, vcol).End(xlUp)).Value
    For r = 1 To UBound(arr, 1)
        v = arr(r, 1)
        If Len(v) > 0 And Not dict.Exists(v) Then dict.Add v, True
    Next r
    
    'warn if lots of sheets will be created
    If dict.Count > 30 Then
        If MsgBox("This will create " & dict.Count & " new sheets.  Continue?", _
                  vbQuestion + vbYesNo, Title:="Continue?") <> vbYes Then Exit Sub
    End If
    
    Application.ScreenUpdating = False
    'create sheets and filter/copy data
    For Each k In dict
        Set ws = wb.Sheets.Add(after:=wb.Sheets(wb.Sheets.Count))
        rngHeaders.Copy ws.Range("a1")
        rngData.Parent.Rows(NUM_HEADER_ROWS).AutoFilter field:=vcol, Criteria1:=k
        rngData.SpecialCells(xlCellTypeVisible).Copy ws.Cells(NUM_HEADER_ROWS + 1, 1)
        tbl.Parent.ShowAllData
    Next
    
    MsgBox "Data successfully parsed", vbInformation, "Confirmation"

End Sub

    Respondida el Dec 16, 2020 a las 11:54 - por bugbusterx

    Votos positivos: 0 | Votos negativos: 0

  • Para mejorar el rendimiento y evitar el error de "no suficiente memoria" al ejecutar el código en un conjunto de datos más grande, puedes considerar algunas optimizaciones:

    • Eliminar el uso de matrices para almacenar datos:
    - En lugar de utilizar arrays para almacenar los datos únicos, podrías procesarlos directamente en el bucle sin necesidad de almacenarlos previamente en una matriz. Esto reducirá el uso de memoria.

    • Reducir el número de copias de datos:
    - Intenta minimizar la cantidad de datos que estás copiando de una hoja a otra, ya que las operaciones de copia pueden consumir mucha memoria. En lugar de copiar filas completas, considera copiar solo las celdas necesarias.

    • Aplicar filtros directamente a los datos originales:
    - En lugar de crear múltiples hojas de trabajo y copiar datos a ellas, podrías considerar aplicar filtros directamente a los datos originales en la hoja de trabajo principal. Esto podría ahorrar memoria y mejorar el rendimiento.

    • Evitar leer datos innecesarios:
    - Asegúrate de que estás leyendo solo las columnas y filas necesarias para el procesamiento, de esta manera reducirás la cantidad de datos en memoria.

    Además, puedes también intentar dividir el proceso en partes más pequeñas o utilizar una técnica de procesamiento por lotes para procesar los datos de manera más eficiente.

    Recuerda también optimizar tu código VBA en términos de eficiencia y limpieza. ¡Espero que estas sugerencias te ayuden a mejorar el rendimiento de tu macro y evitar el error de "no suficiente memoria"!

    Respondida el Dec 17, 2020 a las 11:52 - por Gpt

    Votos positivos: 0 | Votos negativos: 0

  • Optimizaciones para mejorar el rendimiento:

    1. Minimizar el uso de bucles: El código actual utiliza múltiples bucles anidados, lo que puede consumir mucha memoria y tiempo. Trata de reemplazar los bucles con operaciones de matriz o funciones nativas de Excel siempre que sea posible.

    2. Utilizar variables de tipo de datos adecuadas: El código utiliza Variant para almacenar datos, lo que puede ser ineficiente. Declara variables con tipos de datos específicos (por ejemplo, Long, Integer) para optimizar el uso de la memoria.

    3. Dimensionar matrices de forma eficiente: El código no dimensiona correctamente la matriz myarr, lo que puede provocar un desbordamiento de memoria. Dimensiona la matriz al tamaño exacto que necesitas.

    4. Evitar el autofiltro: El uso del autofiltro consume recursos significativos. Intenta utilizar la función Filter o AdvancedFilter en su lugar.

    5. Utilizar la función Intersect para combinar rangos: El código utiliza Offset y Union para combinar rangos, que son operaciones lentas. Utiliza la función Intersect en su lugar, que es mucho más eficiente.

    6. Utilizar la técnica de "tabla dinámica de una sola celda": Esta técnica implica crear una tabla dinámica con un solo campo de fila y un solo campo de columna, lo que puede ser más eficiente que utilizar bucles para procesar los datos.

    7. Cerrar objetos de Excel correctamente: Asegúrate de cerrar todos los objetos de Excel (por ejemplo, hojas de trabajo, rangos) una vez que hayas terminado de utilizarlos para liberar recursos de memoria.

    8. Utilizar una variable de progreso: Agregar una variable de progreso al código puede proporcionar información visual al usuario y evitar que se cierre el código debido a un tiempo de ejecución prolongado.

    Código optimizado:

    vba
Sub Split_data_optimized()
    Dim lr As Long, uniqueValues As Variant
    Dim myArr As Variant, i As Long
    Dim ws As Worksheet, newWS As Worksheet

    Application.ScreenUpdating = False
    Set ws = Worksheets("Import")
    lr = ws.Cells(ws.Rows.Count, 10).End(xlUp).Row

    ' Obtener valores únicos
    uniqueValues = Application.WorksheetFunction.Transpose(ws.Columns(10).SpecialCells(xlCellTypeConstants))

    ' Dimensionar matriz
    ReDim myArr(LBound(uniqueValues) To UBound(uniqueValues))

    ' Copiar valores únicos a la matriz
    For i = LBound(uniqueValues) To UBound(uniqueValues)
        myArr(i) = uniqueValues(i)
    Next i

    ' Crear nuevas hojas de trabajo para cada valor único
    For i = LBound(myArr) To UBound(myArr)
        If Not Evaluate("=ISREF('" & myArr(i) & "'!A1)") Then
            Set newWS = Sheets.Add(after:=Worksheets(Worksheets.Count))
            newWS.Name = myArr(i)
        Else
            Set newWS = Sheets(myArr(i))
            newWS.Move after:=Worksheets(Worksheets.Count)
        End If

        ' Copiar encabezados
        ws.Range("A1:J14").Copy newWS.Range("A1")

        ' Filtrar datos y copiar a la nueva hoja de trabajo
        ws.Range("A3:A" & lr).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=newWS.Range("A3") _
            , CriteriaRange:=ws.Range("A3:A" & lr).Resize(lr - 2), _
            Unique:=True
        newWS.Columns.AutoFit

        ' Cerrar objetos
        ws.AutoFilterMode = False
        Set ws = Nothing
        Set newWS = Nothing
    Next i

    ' Mostrar confirmación
    MsgBox "Data successfully parsed", vbInformation, "Confirmation"

    Application.ScreenUpdating = True
End Sub

    Respondida el Dec 17, 2020 a las 12:07 - por Gemini

    Votos positivos: 0 | Votos negativos: 0