+ Rispondi al Thread
Visualizzazione dei risultati da 1 a 3 su 3

Discussione: EXCEL 2010 VBA: Codice Troppo Lento

  1. #1
    L'avatar di Elimar
    Elimar non è in linea Scribacchino
    Luogo
    Milano
    Post
    647

    EXCEL 2010 VBA: Codice Troppo Lento

    Ciao a tutti,
    ho creato un codice per transcodificare dei numeri in Testo e successivamente inserire dei valori in base delle formule in altre celle.
    Tutto questo è nato dal fatto che lasciare le formule nel foglio "lo appesantiva troppo".

    Il tutto funzionava correttamente ma ora che le righe da analizzare sono diventate oltre 75000 il codice ma TROPPO lento, secondo voi esiste un modo per ottimizzarlo e quindi riuscire a velocizzare la compilazione dei dati?

    Sintetizzo brevemente cosa vado a fare:
    1) apro il file del mese precedente quello che devo analizzare;
    2) aggiungendo 10 giorni alla data massima che trovo nel foglio, individuo il mese che andrò ad analizzare e dove salvarlo;
    3) cancello i vecchi dati e copio i dati di un altro file;
    4) Decodifico i numeri della colonna I e inserisco i valori ricalcolati. (qui si rallenta parecchio)



    codice:
    Sub CreaRN()
    
    '    Application.ScreenUpdating = False
        Application.Calculation = xlManual
      
        Set CDir = CreateObject("Scripting.FileSystemObject")
    
        Msg = MsgBox("Premendo il pulsante SI si procederà con la cancellazione dei dati presenti nei fogli '1030' (MPS) e '3442' (WIDIBA)    e l 'acquisizione dei nuovi dati per l'elaborzione di una nuova RN" & _
         vbNewLine & "Premendo il pulsante NO si bloccherà la procedura", vbExclamation + vbYesNo, "Crazione del nuovo file per la RN ....")
        
        If Msg = vbYes Then
        
            MsgUF1 = "Sta per essere creato il Nuovo file per la Raccolta Netta"
            UserForm1.Show
        
        
    'Voglio proseguire con la creazione del nuovo file
    'in base al mese e all'anno della data registrazione massima che trovo nella colonna M del foglio 1030 procedo a verificare che siano
    'già state create le directory necessarie in caso contrario procedo io alla creazione delle stesse.
    'seleziono il foglio contenente tutti i dati di MPS
            
            Sheets("1030").Select
            MiaData = Application.WorksheetFunction.Max(Range("N:N")) + 10
            
            If Month(MiaData) >= 1 And Month(MiaData) <= 3 Then
    
    'Imposto la directory dove voglio salvare il file
                Periodo = "\I Trimestre "
        
            ElseIf Month(MiaData) >= 4 And Month(MiaData) <= 6 Then
    
    'Imposto la directory dove voglio salvare il file
                Periodo = "\II Trimestre "
        
            ElseIf Month(MiaData) >= 7 And Month(MiaData) <= 9 Then
    
    'Imposto la directory dove voglio salvare il file
                Periodo = "\III Trimestre "
        
            ElseIf Month(MiaData) >= 10 And Month(MiaData) <= 12 Then
    
    'Imposto la directory dove voglio salvare il file
                Periodo = "\IV Trimestre "
    
            End If
            
    'Imposto la directory dove voglio salvare il file
            MiaDir = "\\AP000000012022\Dati5823P\Reportistica\Segnalazioni\Raccolta Netta\Segnalazioni\Anno " & Year(MiaData) & Periodo & Year(MiaData) & "\" & Format((MiaData), "mm") & " - " & StrConv(Format(MiaData, "mmmm"), vbProperCase)
    
    'Ricavo il nome dell'Analisi che manderemo alla Direzione in base alla data registrazione più alta che trovo nel foglio
    'precedentemente selezionato
            MioNome = "RN " & StrConv(Format((MiaData), "mmmm yyyy"), vbProperCase) & ".xlsm"
    
            
    'A questo verifico se la directory esiste altrimenti procedo a crearla.
            If CDir.folderexists(MiaDir) = False Then
                MkDir (MiaDir)
                ActiveWorkbook.SaveAs MiaDir & "\" & MioNome
            Else
    'Verifico se esiste il file
                If Dir$(MioNome) = "" Then
    'Il file non esiste procedo a salvarlo con nome dove voglio
                    ActiveWorkbook.SaveAs MiaDir & "\" & MioNome
                End If
            
            End If
    
    ' Test per verificare se il file è aperto.
            If IsFileOpen(MiaDir & "\Indagine Raccolta Netta.xlsx") Then
            Else
    ' Apro la cartella che mi interessa.
                Workbooks.Open MiaDir & "\Indagine Raccolta Netta.xlsx"
                Indagine = ActiveWorkbook.Name
        
            End If
            
            MsgUF1 = "Verranno copiati i dati della nuova raccolta netta .... Questa operazione richiederà parecchi minuti ..."
            UserForm1.Show
            
    'Pulisco il foglio "1030"
            Windows(MioNome).Activate
            Sheets("1030").Select
            Range("A3:V" & Sheets("1030").Range("A3").End(xlDown).Row).Select
            Selection.ClearContents
            Range("A3").Select
            Foglio = 1
            CopioDati
            
    'Pulisco il foglio "3442"
            Sheets("3442").Select
            Range("A3:N" & Sheets("3442").Range("A3").End(xlDown).Row).Select
            Selection.ClearContents
            Range("A3").Select
            Foglio = 2
            CopioDati
            
            Application.DisplayAlerts = False
            Windows(Indagine).Close
            Application.DisplayAlerts = True
            
            Workbooks.Open ("\\Ap000000012022\Dati5823P\Reportistica\Segnalazioni\Raccolta Netta\Filiali e Linee.xlsx")
            MyArrayFil = Sheets("Filiali MPS").Range("A2").CurrentRegion
            MyArrayFam = Sheets("Famiglie").Range("a2").CurrentRegion
            ActiveWorkbook.Close
            
            
            Sheets("1030").Select
            Range("A3").Select
            
    'Si procede alla decodifica dei MDS e alla riclassificazione di Specifici MDS come nel caso dei Key Client, degli Assenti
    'delle gestioni intestate ad AXA o a MPS Fiduciaria.
    
    'Viene creata un'array per gestire i codici MDS e la loro Decodifica
    
            MsgUF1 = "Verranno decodificati i MDS"
            UserForm1.Show
            
            MyArray = Sheets("MDS").Range("A2").CurrentRegion
            URMDS = Sheets("MDS").Range("A2").End(xlDown).Row
            
            MyArrayAXA = Sheets("Particolarità").Range("A2").CurrentRegion
        
    
    '************************************************************
    '************************************************************
    '**                                                                                         **
    ** Da qui sarebbe da "ottimizzare"                                              **
    '**                                                                                         **
    '************************************************************
    '************************************************************
        
            Sheets("1030").Select
            Range("I3").Select
        
            Do While ActiveCell.Offset(0, 1) <> Empty
                
                Select Case ActiveCell.Value
                
                    Case MyArray(2, 1)                      '0 Assente
                        ActiveCell.Value = MyArray(2, 3)
                        Compila_AT_DTM
                        
                    Case MyArray(3, 1), MyArray(4, 1)      '11 e 12 Enti
                        ActiveCell.Value = MyArray(3, 3)
                        Compila_AT_DTM
                        
                    
                    Case MyArray(5, 1), MyArray(6, 1)      '20 e 21 Key Client
                        ActiveCell.Value = WorksheetFunction.VLookup(ActiveCell.Offset(0, -6), MyArrayAXA, 6, 0)
                        ActiveCell.Offset(0, 12).Value = WorksheetFunction.VLookup(ActiveCell.Offset(0, -6), MyArrayAXA, 5, 0)
                        Compila_AT_DTM
                    
                    Case MyArray(7, 1)                      '30 Small Business
                        If ActiveCell.Offset(0, 1) = 640493 Then
                            ActiveCell.Value = "PRIVATE"
                        Else
                            ActiveCell.Value = MyArray(7, 3)
                        End If
                        Compila_AT_DTM
                    
                    Case MyArray(8, 1), MyArray(10, 1)      '40 PMI
                        ActiveCell.Value = MyArray(8, 3)
                        Compila_AT_DTM
                    Case MyArray(9, 1)                      '47 PF
                        ActiveCell.Value = MyArray(8, 3)
                        Compila_AT_DTM
                    Case MyArray(11, 1)                     '60 Valore Famiglia
                        ActiveCell.Value = MyArray(11, 3)
                        Compila_AT_DTM
                    Case MyArray(12, 1)                     '70 Valore Risparmio
                        ActiveCell.Value = MyArray(12, 3)
                        Compila_AT_DTM
                    Case MyArray(13, 1)                     '80 Premium
                        ActiveCell.Value = MyArray(13, 3)
                        Compila_AT_DTM
                    
                    Case MyArray(14, 1) To MyArray(15, 1)   '90 Private
                        ActiveCell.Value = MyArray(14, 3)
                        Compila_AT_DTM
                    Case MyArray(16, 1)                     '92 Private Top
                        ActiveCell.Value = MyArray(16, 3)
                        Compila_AT_DTM
                    
                    
                    
                    
                    
           End Select
                ActiveCell.Offset(1, 0).Select
            Loop
                
                
                
        Else
    'Non voglio proseguire nella creazione del File
            Exit Sub
        End If
        
        
        
        
        Application.Calculation = xlAutomatic
        Application.ScreenUpdating = True
    End Sub
    
    
    
    Sub Compila_AT_DTM()
            
        If ActiveCell.Offset(0, -7).Value <> 5823 Then
            ActiveCell.Offset(0, 6).Value = WorksheetFunction.VLookup(ActiveCell.Offset(0, -7), MyArrayFil, 4, 0)
        Else
            If ActiveCell.Value = "PRIVATE" Then
                ActiveCell.Offset(0, 6).Value = WorksheetFunction.Index(MyArrayFil(4), WorksheetFunction.Match(ActiveCell.Offset(0, 12), MyArrayFil(7), 0))
            ElseIf ActiveCell.Value = "PRIVATE TOP" Then
                ActiveCell.Offset(0, 6).Value = WorksheetFunction.Index(MyArrayFil(4), WorksheetFunction.Match(ActiveCell.Offset(0, 12), MyArrayFil(8), 0))
            Else
                ActiveCell.Offset(0, 6).Value = WorksheetFunction.VLookup(ActiveCell.Offset(0, -7), MyArrayFil, 4, 0)
            End If
        End If
        ActiveCell.Offset(0, 7).Value = WorksheetFunction.VLookup(ActiveCell.Offset(0, -7), MyArrayFil, 6, 0)
        ActiveCell.Offset(0, 8).Value = WorksheetFunction.VLookup(ActiveCell.Offset(0, -5), MyArrayFam, 3, 0)
        ActiveCell.Offset(0, 9).Value = WorksheetFunction.VLookup(ActiveCell.Offset(0, -5), MyArrayFam, 4, 0)
        ActiveCell.Offset(0, 10).Value = WorksheetFunction.VLookup(ActiveCell.Offset(0, -5), MyArrayFam, 5, 0)
        ActiveCell.Offset(0, 11).Value = WorksheetFunction.VLookup(ActiveCell.Offset(0, -5), MyArrayFam, 13, 0)
        ActiveCell.Offset(0, 13).Value = WorksheetFunction.VLookup(ActiveCell.Offset(0, -5), MyArrayFam, 18, 0)
    
    End Sub
    
    
    
    Sub CopioDati()
    'Copio i dati della colonna "BANCA"
            Windows(Indagine).Activate
            Sheets(Foglio).Select
            URIndagine = Sheets(Foglio).Range("A8").End(xlDown).Row
            Copia
            ActiveCell.Offset(0, 1).Select
    
            Incolla
            
    'Copio i dati della colonna "FILIALE"
            Copia
            ActiveCell.Offset(0, 2).Select
            
            Incolla
            
    'Copio i dati della colonna "DOSSIER"
            Copia
            ActiveCell.Offset(0, 3).Select
            
            Incolla
            
    'Copio i dati della colonna "LINEA"
            Copia
            ActiveCell.Offset(0, 3).Select
            
            Incolla
            
    'Copio i dati della colonna "VALUTA"
            Copia
            ActiveCell.Offset(0, 1).Select
    
            Incolla
            
            MsgUF1 = "Siamo più o meno a metà dell'attività ...."
            UserForm1.Show
    
    
    'Copio i dati della colonna "INSERIMENTO"
            Copia
            ActiveCell.Offset(0, 1).Select
                
            Incolla
            
    'Copio i dati della colonna "CAUSALE"
            Copia
            ActiveCell.Offset(0, 1).Select
        
            Incolla
            
    'Copio i dati della colonna "IMPORTO"
            Copia
            ActiveCell.Offset(0, 1).Select
            
            Incolla
            
    'Copio i dati della colonna "MDS"
            Copia
            ActiveCell.Offset(0, 1).Select
            
            Incolla
            
    'Copio i dati della colonna "NDC"
            Copia
            ActiveCell.Offset(0, 2).Select
            
            Incolla
            
    
    'Copio i dati della colonna "TIPO"
            Copia
            ActiveCell.Offset(0, 7).Select
            
            Incolla
            
    'Copio i dati della colonna "PRODOTTO_ASS"
            Copia
            ActiveCell.Offset(0, 1).Select
            
            Incolla
            
    'Copio i dati della colonna "CATEGORIA_ASS"
            Copia
            ActiveCell.Offset(0, 1).Select
            
            Incolla
            
    'Copio i dati della colonna "REGISTRAZIONE"
            Copia
            ActiveCell.Offset(0, 2).Select
            
            Incolla
    
    End Sub
    
    
    
    Sub Copia()
            Windows(Indagine).Activate
            Range(Cells(8, ActiveCell.Column), Cells(URIndagine, ActiveCell.Column)).Select
            Selection.Copy
    End Sub
    
    Sub Incolla()
            Windows(MioNome).Activate
            ActiveSheet.Paste
            ActiveCell.Offset(0, 1).Select
    End Sub
    Mi rendo conto che il codice che ho postato è un po' lungo ma ho pensato che in questo modo sarebbe forse stato un po' più chiaro ....

    Ringrazio tutti per i suggerimenti che vorrete fornirmi.

    Buone Feste
    Ciao

    Andrea

    Spero di esserti stato di aiuto.

  2. #2
    LuDo non è in linea Scolaretto
    Luogo
    Parigi
    Post
    119
    Ciao, Andrea.
    Purtroppo non ho il tempo di provare il tuo codice in dettaglio, però una cosa mi salta agli occhi:
    codice:
            Copia
            ActiveCell.Offset(0, 3).Select
            
            Incolla
    Non sarà tutta questa procedura piena di Select a impegnare le risorse del computer?
    Poi non vedo a cosa corrispondono "Copia" e "Incolla": sono altre Sub?
    Se lo avessi fatto io, avrei pensato piuttosto ad un meccanismo tipo (occhio, scrivo a braccio e senza provare!):

    codice:
    Var1=Range("TalDeiTali").Value
    ActiveCell.Offset(0, 3)=Var1
    Var2=Range("PincoPallino").Value
    ActiveCell.Offset(0, 4)=Var2
    Ciao, fai sapere. Luca

  3. #3
    darionardella non è in linea Novello
    Post
    3

    Cool Codice troppo lento

    Ciao Andrea,
    credo che il Tuo codice sia "molto lento" per una serie di motivi, che segnalo anche a scopo didattico:
    a) quando si implementano dei cicli ricorsivi (do while o do until etc...) sulle celle è assolutamente necessario ridurre al minimo l'uso dell'attivazione delle celle medesime. E' sufficiente leggere o scrivere i valori ricorrendo all'istruzione cells(riga,colonna).value, senza attivare le celle stesse (.select);
    b) lo scan delle celle da leggere/scrivere può essere fatto incrementando l'indice riga e/o colonna, a partire dalla prima (nel Tuo caso riga 3 e colonna 9>I3);
    c) trattandosi di loop, per tutte le variabili utilizzate nel loop è "obbligatorio" dimensionarle preventivamente con assegnazione del tipo opportuno: dim riga as long, colonna as long, rigamax as long,rx as long
    d) riga e colonna le puoi ottenere con riga=Range("I3").row e colonna=Range("I3").column
    rigamax la ricavi da rigamax=cells(riga,colonna+1).end(xldown).row
    e) a questo punto implementi un ciclo
    Do until rx>rigamax
    valore=cells(rx,colonna).value'leggi il valore della cella senza spostare la selezione sul foglio!
    cells(rx,colonna).value=........'scrivi il valore che vuoi nella cella
    'codice vario
    rx=rx+1'incrementi la riga per la prossima cella senza selezionare la cella fisica
    loop

    Nello spirito del forum Ti "sprono" a modificare il codice secondo i suggerimenti che Ti ho indicato.....
    Non attivare mai le celle fisiche (.select o .activate) per leggere dei valori o scriverli, usa l'istruzione cells(riga,colonna).value!
    Adatta la riga e la colonna per la cella che ti serve.
    Il codice ne guadagna in semplicità, chiarezza e ....velocità!

    Dammi notizie dei progressi....

    Dario

+ Rispondi al Thread

Permessi di invio

  • Non puoi inserire discussioni
  • Non puoi inserire repliche
  • Non puoi inserire allegati
  • Non puoi modificare i tuoi messaggi