Optimización de proceso macro grandes datos

:)

Hola! Para todos. El siguiente código me procesó 200 mil filas de datos en 11.69 segundos: ¿Lo evaluarías?...

Sub Copiar_Numeros_4()
Dim Mat1, Mat2, Q&, i&, j%, R%, iniTime!
iniTime = Timer
Application.ScreenUpdating = False
Mat1 = Range("a1", Cells(Rows.Count, "u").End(xlUp))
Q = UBound(Mat1): R = UBound(Mat1, 2)
ReDim Mat2(1 To Q, 1 To 10 + R)
R = 0
For i = 1 To Q
  If Mat1(i, 21) > 2 And Mat1(i, 21) < 9 Then
    R = 0
    For j = 1 To 20
      If Mat1(i, j) <> "" Then
        R = 1 + R
        Mat2(i, R) = Mat1(i, j)
      End If
    Next
  End If
Next
DoEvents
Range("v1").Resize(Q, UBound(Mat2, 2)) = Mat2
Application.ScreenUpdating = True
MsgBox "Proceso terminado en " & Format(Timer - iniTime, "0.00 seg")
Mat1 = Empty: Mat2 = Empty
End Sub

Saludos, Mario (Cacho) R.

:)

.

Mario, ya la probé, y arroja un error, lo estoy adjuntando para que lo veas

Gracias

:)

¿Memoria insuficiente?... Entonces y como dice el refrán: - "Si no puedes vencerle: ¡Únete a él!" (Jejjjjejejejeje).

Sub Copiar_Numeros_4()
Dim iniTime!, fRow&, lRow&, k&
iniTime = Timer
Application.ScreenUpdating = False
fRow = 2
lRow = Cells(Rows.Count, "u").End(xlUp).Row
For k = fRow To lRow Step 10000
  Auxiliar Range("a" & k, "u" & Application.Min(k + 10000 - 1, lRow))
  DoEvents
Next
MsgBox "Proceso terminado en " & Format(Timer - iniTime, "0.00 seg")
Application.ScreenUpdating = True
End Sub
Private Sub Auxiliar(Rng As Range)
Dim Q&, i&, j%, R%
Dim Mat1, Mat2
Mat1 = Rng
Q = UBound(Mat1): R = UBound(Mat1, 2)
ReDim Mat2(1 To Q, 1 To 10 + R)
R = 0
For i = 1 To Q
  If Mat1(i, 21) > 2 And Mat1(i, 21) < 9 Then
    R = 0
    For j = 1 To 20
      If Mat1(i, j) <> "" Then
        R = 1 + R
        Mat2(i, R) = Mat1(i, j)
      End If
    Next
  End If
Next
Cells(Rng.Row, "v").Resize(Q, UBound(Mat2, 2)) = Mat2
Mat1 = Empty: Mat2 = Empty
End Sub

Esta variante hace -exactamente- lo mismo que la versión anterior con las siguientes salvedades:

- En lugar de tratar todas las líneas en un solo paso, las va procesando a razón de 10000 filas por vez (advierte la presencia del 10000 en dos líneas del código).

- Incorporé una variable: "fRow" con el valor "2". Eso significa que tus datos comienzan en la fila 2 según muestras en tu imagen a diferencia de tu código inicial que indicaba que todo "esto" comenzaba en la fila 1.

- Sorprendentemente (o no tanto, en rigor) esta variante es un poco más veloz que la anterior.

Ahora sí... ¡Tu PC debería funcionar "sin morirse en el intento"! (Jajjjajajaja)
¿Comentarías?...

Saludos, Mario (Cacho) R.

:)

.

I M P R E S I O N A N T E!!!!!!!!! 208.96 segundos tardo en copiar 999.001 registros.

Si esta velocidad se pudiera trasladar a esta macro que te estoy copiando ya estaría en condiciones de decir que sos realmente una extensión del procesador version humana. Comparar 1000 filas entre si y ese resultado copiarlo en la hoja 2 (por cierto una G E N I A L I D A D de tu colega Dante Amor

Gracias por tu ayuda con la macro de contar números pero necesitaría que me auxilies con la macro de comparar, dado que el tiempo que estoy ganando con la otra lo estoy perdiendo con esta. Muchas Gracias

:)

El solo hecho de estar "poniendo colorcitos" (Interior. ColorIndex) ya hace que tu proceso se torne lentísimo.

Sin perjuicio de ello te re-pregunto:
- ¿Qué es -exactamente- lo que quieres conseguir ahora?...
- ¿Cómo se vinculan este nuevo requerimiento con lo que consultaste inicialmente?
Te lo pregunto pues además de que no entiendo tu "doble objetivo", me estoy preguntando si se pudieran satisfacer ambos objetivos "en un sólo proceso"... ¡Veremos!
Saludos, Mario (Cacho) R.

.

Gracias por tu atención, con respecto a los colores podes sacarlos no los necesito, en su momento lo pedí para controlar si las comparaciones eran cada fila con las otras 999, por eso están coloreadas y por separado. Lo ideal seria que fuera todo un mismo proceso, es decir, la primer macro compara las 1000 filas de 20 números, se fija uno por uno que números se repiten y los copia en la hoja 2 de izquierda a derecha uno detrás del otro que es lo que vos hiciste en base al condicional de la columna U y nos ahorraríamos el proceso de la primer copia por separado. Pero en caso de ser un laburo complejo, solo necesitaría que la Macro que compara tuviera la misma velocidad que la que hiciste vos para copiar.

Muchas Gracias Cacho

:)

¡No entiendo!...

- Si tu base de datos "de origen" es de 1000 filas y las vas comparando "de a dos", entonces el total de comparaciones posibles equivale a las combinaciones de 1000 elementos tomados de a dos. O sea: 499500 casos.

- Este resultado es prácticamente "la mitad" de las "casi" 900 mil filas de datos que mencionabas al inicio de este intercambio.

- Además me doy cuenta que el dato de la columna U representa a la cantidad de elementos de cada fila resultantes de la comparación.

- Todo parece indicar, además, que las filas con 0, 1, 2, 9 y 10 coincidencias parecen no interesarte: ¿Por qué no descartarlas de entrada, digo yo?...

Por favor responde -una a una- las inquietudes planteadas.

Cacho R.

:)

.

Paso a explicarte:

La comparación que hace la macro es fila por fila una por una compara cada fila con las otras 999 (por eso los colores, con eso lo audito)

La fila 1 (A1:T1) compara con la 2 hasta la 1000

La fila 2 (A2:T2) compara con la 1 y de la 3 a la 1000

La fila 3 (A3:T3) compara con la 1 y 2 y de la 4 a la 1000

No se si en ese orden pero eso es lo que hace

Por cierto, si estas desarrollando una macro seria bueno que al iniciar la comparación pudiera elegir el rango a comparar.

Ejemplo:  A1: T1000 pero a veces necesito comparar A1: F1000 sería bueno poder asignarlo yo antes de comenzar a comparar, el procedimiento seria el mismo, las filas serían de menos datos.

En la columna U yo decido con el condicional  que cantidad de numeros iguales comparados me interesan, en este momento necesito las filas que tienen resultados de 3 a 8 numeros por eso el condicional <2 y <9, mañana puedo necesitar =3 otro día >4 es de acuerdo a lo que necesite voy cambiando la macro con el condicional.

Calculo que esa es tu pregunta, y gracias.

:)

Razónalo del siguiente modo, Diego:

- Imagina que comparas la fila 1 con la fila 2 y obtienes 3 coincidencias.

- Y sigues comparando la fila 1 con el resto de las filas.

- Ahora piensa: cuando pasas a comparar la fila 2 con la fila 1 no sólo vas a obtener 3 coincidencias: ¡Sino que obtendrás las mismas 3 coincidencias que inicialmente!

- ¿Estás seguro que deseas duplicar los resultados?... porque de ser así sólo sería necesario comparar la fila 1 con la fila 2: ¡Y después duplicar el resultado! Ya que "eso" representa comparar la fila 2 con la fila 1...

¿Comprendes lo que quiero decirte?... Digo: ¡Es muy raro que no lo hayas advertido!

:)

Ah, y un dato más y no menos importante, el condicional de la copia de datos surge de la celda U que es la fórmula CONTARA de la fila. Lo que yo hago actualmente es asignarle un CONTARA a cada fila para así poder hacer el descarte de las filas que no cumplen con la cantidad de números que necesito.. Todo muy casero porque si bien tengo noción de Excel no se ni un 1% de lo que saben Uds.

Si lo advertí, lo que pasa es que no sabia como resolverlo, la comparación es piramidal, la fila 1 con las 999 siguientes, la fila 2 con las 998, la fila 3 con las 997 y así hasta la fila 999 que solo compara con la 1000. Siempre lo supe pero no sabia como resolverlo en Vba.

:)

Por ello cuando te hablé de las combinaciones de 1000 elementos tomados de a 2, referí a las 499500 comparaciones posibles... ¿Recuerdas?

Como no diste "acuse de recepción" a este dato me di cuenta que este aspecto lo tenías -un tanto- difuso (Jajjajajajajaj).

Vamos a la solución, entonces:

- Prepara dos hojas: Datos y Proceso.

- En "Datos" pondrás (SIEMPRE a partir de la celda A1) tus datos. La cantidad de columnas y/o filas es indistinta (lo que pongas es lo que se procesará).

- En la hoja "Proceso" pondrás (atenti a lo que sigue):

.) En A2, el mínimo a considerar. Para lo que venimos analizando sería 3.

.) En A5, el máximo a considerar. Para lo que venimos analizando sería 8.

- Finalmente ejecutarás la macro que te mostraré a continuación y -si tienes mucha suerte y viento a favor- en unos 20 segundos tendrás tus dos procesos (resumido en uno solo):

Sub Comparación_Múltiple()
'--------------------------
'by Mario (Cacho) Rodríguez
'--------------------------
Dim Mat1, Mat2, Dic, Tmp
Dim Q&, i&, R%, j%, k&, m%, s&, iniTime!, iMin%, iMax%
iniTime = Timer
With Sheets("Proceso")
  .Columns("b").ClearContents
  .[c1].CurrentRegion.Delete xlUp
  iMin = .[a2]: iMax = .[a5]
End With
Application.ScreenUpdating = False
Mat1 = Sheets("Datos").[a1].CurrentRegion
Q = UBound(Mat1): R = UBound(Mat1, 2)
ReDim Mat2(1 To 1000, 1 To R)
For i = 1 To Q - 1
  Set Dic = CreateObject("Scripting.Dictionary")
  On Error Resume Next
    For j = 1 To R: Dic(Mat1(i, j)) = 0: Next
  On Error GoTo 0
  For k = 1 + i To Q
    ReDim Tmp(1 To R): m = 0
    For j = 1 To R
      If Dic.Exists(Mat1(k, j)) Then
        m = 1 + m: Tmp(m) = Mat1(k, j)
      End If
    Next
    If m >= iMin And m <= iMax Then
      s = 1 + s: For j = 1 To m: Mat2(s, j) = Tmp(j): Next
      If s = 1000 Then
        Sheets("Proceso").Cells(Rows.Count, "c").End(xlUp).Offset(1).Resize(s, R) = Mat2
        s = 0
        ReDim Mat2(1 To 1000, 1 To R)
      End If
    End If
  Next
  DoEvents
Next
If s > 0 Then Sheets("Proceso").Cells(Rows.Count, "c").End(xlUp).Offset(1).Resize(s, R) = Mat2
Sheets("Proceso").[c1].CurrentRegion.Columns.AutoFit
Application.ScreenUpdating = True
MsgBox "Procesado en " & Format(Timer - iniTime, "0.00 seg")
Mat1 = Empty: Mat2 = Empty: Dic = Empty
End Sub

Sub Comparación_Múltiple()
'--------------------------
'by Mario (Cacho) Rodríguez
'--------------------------
Dim Mat1, Mat2, Dic, Tmp
Dim Q&, i&, R%, j%, k&, m%, s&, iniTime!, iMin%, iMax%
iniTime = Timer
With Sheets("Proceso")
  .Columns("b").ClearContents
  .[c1].CurrentRegion.Delete xlUp
  iMin = .[a2]: iMax = .[a5]
End With
Application.ScreenUpdating = False
Mat1 = Sheets("Datos").[a1].CurrentRegion
Q = UBound(Mat1): R = UBound(Mat1, 2)
ReDim Mat2(1 To 1000, 1 To R)
For i = 1 To Q - 1
  Set Dic = CreateObject("Scripting.Dictionary")
  On Error Resume Next
    For j = 1 To R: Dic(Mat1(i, j)) = 0: Next
  On Error GoTo 0
  For k = 1 + i To Q
    ReDim Tmp(1 To R): m = 0
    For j = 1 To R
      If Dic.Exists(Mat1(k, j)) Then
        m = 1 + m: Tmp(m) = Mat1(k, j)
      End If
    Next
    If m >= iMin And m <= iMax Then
      s = 1 + s: For j = 1 To m: Mat2(s, j) = Tmp(j): Next
      If s = 1000 Then
        Sheets("Proceso").Cells(Rows.Count, "c").End(xlUp).Offset(1).Resize(s, R) = Mat2
        s = 0
        ReDim Mat2(1 To 1000, 1 To R)
      End If
    End If
  Next
  DoEvents
Next
If s > 0 Then Sheets("Proceso").Cells(Rows.Count, "c").End(xlUp).Offset(1).Resize(s, R) = Mat2
Sheets("Proceso").[c1].CurrentRegion.Columns.AutoFit
Application.ScreenUpdating = True
MsgBox "Procesado en " & Format(Timer - iniTime, "0.00 seg")
Mat1 = Empty: Mat2 = Empty: Dic = Empty
End Sub

¿Comentarios, quejas y/o sugerencias?...

Maestro!!!, la pruebo y te aviso.

Un 10 te queda corto, la puntuación es Excelente! Un 1000!

Lo único que te voy a pedir, y esto no es porque vos hayas hecho algo mal, sino porque yo no te lo pedí en ningún momento es que me permitas utilizar el igual, vale decir que el mínimo y el máximo sean el mismo. Siempre hablamos de desde hasta (de 2 a 9) que seria el ejemplo con el cual arrancamos, pero a veces me toca hacerlo con una 1 sola opción (todas las combinaciones igual a XX) y la macro se basa en el mínimo y el máximo.

Sos un groso, un capo, no tengo adjetivos calificativos más grandes para expresar mi agradecimiento.

Un abrazo, espero la modificación así puedo arrancar.

Muchas Gracias Cacho

:)

Intenta correr el código así:

a) Mínimo=0 y Máximo=2

b) Mínimo=5 y Máximo=5

c) Mínimo=6 y Máximo=100

¿Comprendes qué ocurre en cada caso?...

:)

Lo hago en cada caso y te comento que pasa

Abrazo.-

0 a 2 la macro trajo las comparaciones de 1 y 2 números

5 a 5 la macro trajo las comparaciones de 1 /2 /3 /4 y 5

de 6 a 100 la macro arrojo un error que te estoy copiando

Ahora recordé porque le pedí a Dante que volviera para atrás en la comparación porque necesitaba tomar cada fila como si fuera la primera por este motivo:

Fila 1 tiene 20 números y compara con fila 2 encuentra el 48 y el 54.

Fila 2 tiene 20 números y obvio ya encontró el 48 y 54 pero los números que están en esta fila junto al 48 generan nuevas comparaciones co la fila 1, lo que le dije a Dante era que cada nueva fila tenia que tomarla como si fuerla la primera, se entendió ahora recordé porque lo había pedido y esta bien que así sea.

:)

En la imagen que muestras estás poniendo 6 en A1 y 100 en A5 por lo que me pregunto: ¿Quién habló -alguna vez- de A1?...

Públicamente pido disculpas al gran maestro de Excel Mario " Cacho" Rodriguez dado que el error es mio, REITERO EL ERROR ES MIO, yo sin querer y acostumbrado a utilizar en todas mis bases la celda A1 no utilice la celda A2 que era la correcta para poder ejecutar la Macro.

Desde mi punto de vista este tema estaría resuelto, agradezco la dedicación y el compromiso de Cacho y muchas gracias a el y a todos los expertos que componen este equipo de excelencia en la informática.

Una macro para los volúmenes de información que manejas requiere de que la macro no interactue con la pantalla de excel(flashazos) y en vez de manejar los datos 1 a 1 que lo haga en lotes como hace esta macro, por motivos de memoria el calculo se hizo sobre casi 200, 000 registros dividido en bloque de 2000 (cada bloque tardo menos de 2 segundos en ser procesado)y se tardo 2 minutos y 6 segundos en total funcionando en un equipo del 2008, para un volumen de 900000 debe andar alrededor de los 10 a 15 minutos cuando mucho 20 minutos dependiendo de las características del equipo (procesador, memoria)

Sub formar_secciones()
inicio = Time()
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
Set datos = Range("a1").CurrentRegion
Set funcion = WorksheetFunction
With datos
    filas = .Rows.Count: col = .Columns.Count
    seccion = 2000
    partes = funcion.Quotient(filas, seccion)
    restos = filas Mod seccion
    For i = 1 To partes
        If i = 1 Then Set area = .Resize(seccion, col)
        If i > 1 Then Set area = area.Rows(seccion + 1).Resize(seccion, col)
        area.Name = "area"
        analizar
    Next i
    If restos > 0 Then
        Set area = area.Rows(seccion + 1).Resize(restos, col)
        area.Name = "area"
        analizar
    Else
        End
    End If
End With
.Calculation = xlCalculationAutomatic
.EnableEvents = False
End With
fin = Time()
tiempo = fin - inicio
MsgBox ("terminado en  " & Minute(tiempo) & " minutos y " & Second(tiempo) & " segundos")
End Sub
Sub analizar()
Set area = Range("area")
Set funcion = WorksheetFunction
With area
    filas = .Rows.Count: col = .Columns.Count
    Set destino = .Columns(col + 1).Resize(filas, col - 1)
    matriz = destino
    For i = 1 To filas
        numero = .Cells(i, col)
        If numero > 2 And numero < 9 Then
            x = 1
            For j = 1 To col - 1
                valor = .Cells(i, j)
                If valor = vbNullString Then GoTo siguiente
                matriz(i, x) = valor
                x = x + 1
siguiente:
            Next j
        End If
    Next i
    Range(destino.Address) = matriz
End With
Set matriz = Nothing:   Set destino = Nothing
Set area = Nothing: Set funcion = Nothing
End Sub

Buenos días, James, Ok, la pruebo y te aviso, disculpa que no califique antes recién hoy me conecto

James, la macro esta dividida en 2 partes una de análisis y 1 de formar secciones, como la ejecuto y donde le indico los datos que poseo en la macro original, cuando la corro me dice que hay que setear el área.