Jump to content
imarcd

ANSWERED Como Optimizar Macro Extensa (repetitiva)

Recommended Posts

Hola Amigos, tengo un problema, he intentando de todo para simplificar el codigo de esta macro, pero me surgen muchos errores, es una macro que realiza un filtrado de una lista de agentes,  copia la informacion  de cada agente y compila los datos en otra hoja. el problema es que son 26 agentes y no todos los dias trabajan todos, aunque la macro funciona, se que deben haber alguna forma de mejorarla, ya que es super extensa, pero basicamente el codigo es el mismo, lo que cambian son los criterios (nombres de los agentes) y los rangos AN y AJ, espero me puedan ayudar ha no repetir este codigo 26 veces o mas. o  como colocar variables de una mejor manera, Gracias Expertos

Sub PerAgent()
'
' FiltradoPerAgent
'

    Dim rangomax As Integer
    Dim muestramax As Integer
    Dim muestramin As Integer
    Dim criterio2 As String
    Dim criterio3 As String
    Dim criterio4 As String
    Dim criterio5 As String
    Dim criterio6 As String
    Dim criterio7 As String
    Dim criterio8 As String
    Dim criterio9 As String
    Dim criterio10 As String
    Dim criterio11 As String
    Dim criterio12 As String
    Dim criterio13 As String
    Dim criterio14 As String
    Dim criterio15 As String
    Dim criterio16 As String
    Dim criterio17 As String
    Dim criterio18 As String
    Dim criterio19 As String
    Dim criterio20 As String
    Dim criterio21 As String
    Dim criterio22 As String
    Dim criterio23 As String
    Dim criterio24 As String
    Dim criterio25 As String
    Dim criterio26 As String

rangomax = Worksheets("Main").Range("Z5").Value
muestramax = Worksheets("Main").Range("P9").Value
muestramin = Worksheets("Main").Range("P10").Value
criterio2 = Sheets("Main").Range("AN2").Value
criterio3 = Sheets("Main").Range("AN3").Value
criterio4 = Sheets("Main").Range("AN4").Value
criterio5 = Sheets("Main").Range("AN5").Value
criterio6 = Sheets("Main").Range("AN6").Value
criterio7 = Sheets("Main").Range("AN7").Value
criterio8 = Sheets("Main").Range("AN8").Value
criterio9 = Sheets("Main").Range("AN9").Value
criterio10 = Sheets("Main").Range("AN10").Value
criterio11 = Sheets("Main").Range("AN11").Value
criterio12 = Sheets("Main").Range("AN12").Value
criterio13 = Sheets("Main").Range("AN13").Value
criterio14 = Sheets("Main").Range("AN14").Value
criterio15 = Sheets("Main").Range("AN15").Value
criterio16 = Sheets("Main").Range("AN16").Value
criterio17 = Sheets("Main").Range("AN17").Value
criterio18 = Sheets("Main").Range("AN18").Value
criterio19 = Sheets("Main").Range("AN19").Value
criterio20 = Sheets("Main").Range("AN20").Value
criterio21 = Sheets("Main").Range("AN21").Value
criterio22 = Sheets("Main").Range("AN22").Value
criterio23 = Sheets("Main").Range("AN23").Value
criterio24 = Sheets("Main").Range("AN24").Value
criterio25 = Sheets("Main").Range("AN25").Value
criterio26 = Sheets("Main").Range("AN26").Value

    Application.ScreenUpdating = False
    Sheets("Main").Select
    Range("Z5").Select
' formula para identificar la cantidad de muestra recibida en X dia
    Selection.FormulaArray = _
        "=ROW(OFFSET(Gdrive!R[-4]C[-17],MAX(IF(Gdrive!C[-17]<>"""",ROW(Gdrive!C[-17])))-1,0))"
    Sheets("Gdrive").Select
    Range("I1").Select
         
' Verifica si el agente trabajo o pasa al siguiente agente ACA EMPIZA CODIGO AGENTE1

    If IsEmpty(Sheets("Main").Range("AN2").Value) = True Then
    GoTo SiguienteAgente3
   End If

'Filtramos con criterio en AN1 (Lista con nombres de los agentes)

'ajustar rango de títulos
    Sheets("Gdrive").Select
    Range("A1:S1").Select
'quita filtrado anterior
    If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
'se filtra por col I (nombre del agente)
    ActiveSheet.Range("$A$1:$I$" & Range("A" & Rows.Count).End(xlUp).Row).AutoFilter Field:=9, Criteria1:=[criterio2]
 
' Copia Muestra filtrada
    Sheets("Gdrive").Select
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    
 ' Pega la Muestra a Hoja de cada Agente
    Sheets.Add
    ActiveSheet.Name = Sheets("Main").Range("AJ2").Value
    ActiveSheet.Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
' Verifica si el agente tiene el minimo de muestra

    If IsEmpty(Range("A" & muestramin).Value) = True Then
    GoTo SiguienteAgente3
   End If
   
' Selecciona y Copia la Cantidad de Muestra Maxima por Agente
    Range("A" & muestramax).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight).Offset(0, 10)).Select
    On Error GoTo SiguienteAgente3
    Selection.Delete Shift:=xlUp
    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight).Offset(0, 10)).Select
    Selection.Copy
' Busca la ultima fila con contenido y pega la muestra maxima en el consolidado de todos los agentes
    Sheets("FinalSample").Select
        With Sheets("FinalSample").Range("a" & Rows.Count).End(xlUp).Offset(1)
        .PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        End With
' Deshacer el filtro para el siguiente agente
    Sheets("Gdrive").Select
    Selection.AutoFilter
    
' ACA EMPIEZA CODIGO AGENTE2

SiguienteAgente3:
    If IsEmpty(Sheets("Main").Range("AN3").Value) = True Then
    GoTo SiguienteAgente4
   End If
'ajustar rango de títulos
    Sheets("Gdrive").Select
    Range("A1:S1").Select
    'quita filtrado anterior
    If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
'se filtra por col I
    ActiveSheet.Range("$A$1:$I$" & Range("A" & Rows.Count).End(xlUp).Row).AutoFilter Field:=9, Criteria1:=[criterio3]
 ' Copia Muestra filtrada
    Sheets("Gdrive").Select
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
' Pega la Muestra a Hoja de Agente
    Sheets.Add
    ActiveSheet.Name = Sheets("Main").Range("AJ3").Value
    ActiveSheet.Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 ' Verifica si el agente tiene el minimo de muestra
    If IsEmpty(Range("A" & muestramin).Value) = True Then
    GoTo SiguienteAgente3
   End If
' Selecciona y Copia la Cantidad de Muestra Maxima por Agente
    Range("A" & muestramax).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight).Offset(0, 10)).Select
    On Error GoTo SiguienteAgente3
    Selection.Delete Shift:=xlUp
    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight).Offset(0, 10)).Select
    Selection.Copy
' Busca la ultima fila con contenido y pega la muestra maxima
    Sheets("FinalSample").Select
        With Sheets("FinalSample").Range("a" & Rows.Count).End(xlUp).Offset(1)
        .PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        End With
' Deshacer el filtro para el siguiente agente
    Sheets("Gdrive").Select
    Selection.AutoFilter
 
    
End Sub

 

 

Share this post


Link to post
Share on other sites

Hola @bigpetroman gracias por tu comentario, basicamente lo que quisiera saber es como optimizar esta declaraciones, que tienen un  patron ciclico, para que no sean tan largas y no tener que escribir esa lista de variables tan extensa

 


    Dim rangomax As Integer
    Dim muestramax As Integer
    Dim muestramin As Integer
    Dim criterio2 As String
    Dim criterio3 As String
    Dim criterio4 As String
    Dim criterio5 As String
    Dim criterio6 As String
    Dim criterio7 As String
    Dim criterio8 As String
    Dim criterio9 As String
    Dim criterio10 As String
    Dim criterio11 As String
    Dim criterio12 As String
    Dim criterio13 As String
    Dim criterio14 As String
    Dim criterio15 As String
    Dim criterio16 As String
    Dim criterio17 As String
    Dim criterio18 As String
    Dim criterio19 As String
    Dim criterio20 As String
    Dim criterio21 As String
    Dim criterio22 As String
    Dim criterio23 As String
    Dim criterio24 As String
    Dim criterio25 As String
    Dim criterio26 As String

rangomax = Worksheets("Main").Range("Z5").Value
muestramax = Worksheets("Main").Range("P9").Value
muestramin = Worksheets("Main").Range("P10").Value

criterio2 = Sheets("Main").Range("AN2").Value
criterio3 = Sheets("Main").Range("AN3").Value
criterio4 = Sheets("Main").Range("AN4").Value
criterio5 = Sheets("Main").Range("AN5").Value
criterio6 = Sheets("Main").Range("AN6").Value
criterio7 = Sheets("Main").Range("AN7").Value
criterio8 = Sheets("Main").Range("AN8").Value
criterio9 = Sheets("Main").Range("AN9").Value
criterio10 = Sheets("Main").Range("AN10").Value
criterio11 = Sheets("Main").Range("AN11").Value
criterio12 = Sheets("Main").Range("AN12").Value
criterio13 = Sheets("Main").Range("AN13").Value
criterio14 = Sheets("Main").Range("AN14").Value
criterio15 = Sheets("Main").Range("AN15").Value
criterio16 = Sheets("Main").Range("AN16").Value
criterio17 = Sheets("Main").Range("AN17").Value
criterio18 = Sheets("Main").Range("AN18").Value
criterio19 = Sheets("Main").Range("AN19").Value
criterio20 = Sheets("Main").Range("AN20").Value
criterio21 = Sheets("Main").Range("AN21").Value
criterio22 = Sheets("Main").Range("AN22").Value
criterio23 = Sheets("Main").Range("AN23").Value
criterio24 = Sheets("Main").Range("AN24").Value
criterio25 = Sheets("Main").Range("AN25").Value
criterio26 = Sheets("Main").Range("AN26").Value

 

Share this post


Link to post
Share on other sites
Dim criterio(26)
'--
For i = 2 To 26
   criterio(i) = Sheets("Main").Range("AN" & i).Value
Next
'--
'Y luego usas:
'  criterio(2) en lugar de criterio2
'  criterio(3) en lugar de criterio3
'  ....
'  ....
'  criterio(26) en lugar de criterio26
'

 

Sin archivo y sin más explicaciones, es lo único que se te puede decir.

 

.

Edited by Antoni

Share this post


Link to post
Share on other sites
Guest
This topic is now closed to further replies.

INFORMACIÓN BÁSICA SOBRE PROTECCIÓN DE DATOS

Responsable: Sergio Andrés Celemín

Finalidad: Moderar y responder comentarios de usuarios. Recuerda que la información que facilites es pública, y los datos que incluyas los leerá cualquier visitante de esta web, así como el avatar que poseas.

Legitimación: Consentimiento del interesado.

Destinatarios: Hetzner Online GmbH.

Derechos: Puedes ejercitar en cualquier momento tus derechos de acceso,
rectificación, supresión, oposición y demás derechos legalmente establecidos a
través del email sergio@ayudaexcel.com.

Información adicional: Encontrarás más información en la política de privacidad.




×
×
  • Create New...

Important Information

Privacy Policy


CTA Templates.png