VBA Inserimento righe tra date mancanti 16min



  • VBA - Inserimento righe tra date mancanti - 16min di GaBo (utente non iscritto) data: 22/12/2016 20:26:37

    Salve a tutti, ho realizzato una macro in VBA che in un elenco formato da: 15 colonne(O:AC) x 4000 righe circa, contenente nella colonna "T", i giorni dell'anno seriali(36965,36966...)esclusi i festivi, inserisce "n" righe, equivalenti ai giorni mancanti tra le date indicate in elenco; aggiunge le date mancanti (giorni festivi)rispettando ovviamente l'ordine di data. La macro è funzionante ma è molto lenta, impiega 16 minuti per inserire praticamente ogni 5 righe (lun/ven) 2 righe vuote (sab/dom). L'inserimento delle righe vuote è lentissimo, sapreste indicarmi cortesemente, qualora dovesse esserci, un modo alternativo per arrivare allo stesso risultato impiegando qualche secondo? Il problema è il limite di velocità di excel? eventualmente ci sono linguaggi di programmazione che potrebbero effettuare l'operazione nel tempo di un click o in qualche secondo? Grazie mille
     
    Sub InsertMissingRows()
        Dim righedains As Integer
        Dim X As Long
        Dim lastrow As Long
        Dim StartRow As Long
        Dim Difference As Long
        Dim pippo As Integer
        Dim UR As Integer
        Dim strUR As Integer
       
     UR = Range("T" & Rows.Count).End(xlUp).Row
     strUR = CStr(UR)    
        
        righedains = Cells(2, 20) - Cells(20, 12)
        If righedains > 0 Then
            Range("o2:ac" & (1 + righedains)).Select
        Application.CutCopyMode = False
        Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    
    Else
    End If
    
    'inserisci righe blocco 1
    
    For Each cl In ActiveSheet.Range("t2:t" & strUR)
    
     If cl <> "" Then
     pippo = cl.Row
     If cl > 0 Then
     GoTo inserisciblocco01:
     End If
     End If
    Next
        
    inserisciblocco01:
          
            Const OrderColumn01 As String = "T"
            StartRow = pippo
            lastrow = Cells(Rows.Count, OrderColumn01).End(xlUp).Row
            For X = lastrow To StartRow + 1 Step -1
            Difference = Cells(X, OrderColumn01).Value - Cells(X - 1, OrderColumn01)
            If Difference > 1 Then
            Range("P" & X, "Z" & X).Resize(Difference - 1).Insert
            End If
            Next
            lastrow = Cells(Rows.Count, OrderColumn01).End(xlUp).Row
            Cells(StartRow, OrderColumn01).Resize(lastrow - StartRow + 1).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=1+R[-1]C"
            Columns("T").Value = Columns("T").Value
        
       End Sub


  • di patel data: 22/12/2016 20:53:43

    allega un file di excel di 100 righe per testare la macro


  • di GaBo (utente non iscritto) data: 22/12/2016 21:54:35

    Buonasera Patel, allego il file.
    Grazie


  • di patel data: 23/12/2016 09:01:29

    inserisci all'inizio la riga
    Application.ScreenUpdating = False
    e alla fine
    Application.ScreenUpdating = True
    quanto guadagni ?

    prova ad eliminare le ultime 3 righe dopo il next, quanto guadagni ?
    il riempimento degli spazi vuoti potrebbe essere fatto in corso d'opera.


  • di GaBo (utente non iscritto) data: 23/12/2016 10:47:43

    Patel!!! non so come ringraziarla!!! strepitoso!! con la Sua indicazione, la macro passa da 16 minuti per svolgere l'operazione ad appena 1 minuto!!
    Grazie mille! Secondo Lei, la macro è ancora perfezionabile o questo è il limite massimo ottenibile con vba - excel?
    Grazie ancora Aguri di Buon Natale a tutti!
    GaBo


  • di patel data: 23/12/2016 12:55:13

    probabilmente è migliorabile adottando una strategia completamente diversa, trasferendo tutta la tabella in una collection, inserendo gli elementri mancanti e poi riportando il tutto sul foglio, ma questo esula dalle mie capacità.
    Poiccé l'argomento è interessante tolgo il risolto per attendere l'intervento di altri


  • di GaBo (utente non iscritto) data: 24/12/2016 01:09:02

    Buonasera Patel, purtroppo ho cantato vittoria troppo presto! Sono ritornato sul file di questa mattina e mi sono accorto di aver fatto il test su un file con appena 250 righe e non su quello da 4000. Quindi ho riprovato le indicazioni che Lei mi aveva dato, sul file corretto e permangono i 16minuti per eseguire la macro quindi non è cambiato nulla.


  • di patel data: 24/12/2016 08:31:06

    non è possibile che tu non guadagni niente, incolla qui la macro modificata


  • di GaBo (utente non iscritto) data: 24/12/2016 10:20:53

    Buongiorno Patel, guardi ho fatto delle prove ulteriori, ho cancellato tutte le formule, percentuali, differenze, ecc, che avevo posizionato lateralmente rispetto all'elenco, ed in effetti lasciando solo l'elenco dei dati senza che ci siano riferimenti a formule, riduce i tempi di esecuzione macro, rispetto ai 16 minuti impiega qualcosa in più di 2 minuti. Allego comunque il file con le 4000 righe circa, nel caso in cui si riuscisse ad ottenere qualcosa di meglio. Purtroppo la mia analisi si basa su diversi prodotti e quindi il tempo di calcolo della macro è determinante. Devo capire se mi conviene continuare su questa strada o cambiare totalmente con linguaggi differenti. Grazie Patel


  • di patel data: 25/12/2016 09:56:28

    anche a me impiega 2 minuti, non mi risulta che si possa operare su file excel con altri linguaggi, però dovrebbe essere possibile fare tutte le operazioni in memoria invece che sul foglio guadagnando tempo


  • di patel data: 26/12/2016 10:32:58

    prova questa soluzione di Cromagno che lavora in memoria 
     
    Sub InsertMissingRows()
    Dim StartRow As Long, lastrow As Long, r As Long, NewData()
    Dim DataMatch As Date, MoreRows As Long, Difference As Long
    Dim c As Integer
    t1 = Timer
    Application.ScreenUpdating = False
    StartRow = 2
    lastrow = Cells(Rows.Count, "T").End(xlUp).Row
    Difference = Range("T" & lastrow).Value - Range("T2").Value
    ReDim NewData(1 To Difference + 1, 1 To 11)
    For c = 16 To 26
        NewData(1, c - 15) = Cells(2, c).Value
    Next c
    MoreRows = 2
    DataMatch = Range("T2").Value
    
    For r = 3 To lastrow
        If r = lastrow Then
            For c = 16 To 26
                NewData(UBound(NewData, 1), c - 15) = Cells(lastrow, c).Value
            Next c
        Else
            DataMatch = Range("T" & r - 1).Value
            Difference = Range("T" & r).Value - DataMatch - 1
            n = 1
            For j = MoreRows To MoreRows + Difference
              NewData(j, 5) = DataMatch + n
              n = n + 1
            Next
            MoreRows = MoreRows + Difference
            
            For c = 16 To 26
                NewData(MoreRows, c - 15) = Cells(r, c).Value
            Next c
        End If
        MoreRows = MoreRows + 1
    Next r
    
    Range("P" & 2 & ":Z" & lastrow).ClearContents
    
    For r = 1 To UBound(NewData, 1)
        For c = 16 To 26
            Cells(r + 1, c).Value = NewData(r, c - 15)
        Next c
    Next r
    Erase NewData
    Range("T:T").NumberFormat = "General"
    
    Application.ScreenUpdating = True
    MsgBox Timer - t1
    End Sub


  • di scossa data: 26/12/2016 13:13:05

    Ciao,

    la sub sottostante impiega, sul mio pc, poco più di mezzo secondo per completare le date mancanti nel file da 4000 righe.



    scossa's web site
    Se tu hai una mela, ed io ho una mela, e ce le scambiamo, allora tu ed io abbiamo sempre una mela per uno. Ma se tu hai un'idea, ed io ho un'idea, e ce le scambiamo, allora abbiamo entrambi due idee.
    (George Bernard Shaw)

     
    [CODE]'---------------------------------------------------------------------------------------
    ' Procedure : CompletaDate
    ' Author    : scossa
    ' Date      : 26/12/2016
    ' Purpose   :
    '---------------------------------------------------------------------------------------
    '
    Public Sub CompleteAllDate()
    
      Dim wb As Workbook
      Dim wsTrg As Worksheet
      Dim rngFr As Range
      Dim rngTo As Range
      Dim bCalc As XlCalculation
      Dim j As Long
      Dim k As Long
      Dim nRow As Long
      Dim nLR As Long
      Dim nDiff As Long
      Dim nDStart As Double
      Dim nDStop  As Double
      Dim nStart As Single
      Dim nStop As Single
      
      
      nStart = Timer
      On Error GoTo CompleteAllDate_Error
    
      With Application
        bCalc = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
      End With
      
      Set wb = ThisWorkbook
      Set wsTrg = Foglio1
      
      With wsTrg
        nLR = .Cells(Rows.Count, 20).End(xlUp).Row
        nRow = nLR + 1
        nDStart = .Cells(2, 20).Value
        nDStop = .Cells(nLR, 20).Value
        For j = 2 To nLR
          nDStart = .Cells(j, 20).Value + 1
          nDStop = .Cells(j + 1, 20).Value
          nDiff = nDStop - nDStart
          For k = 1 To nDiff
            With .Cells(nRow, 20)
              .Value = nDStart
              .Offset(0, -4).Value = Format(CDate(nDStart), "yyyy")
              .Offset(0, -3).Value = Format(CDate(nDStart), "mm")
              .Offset(0, -2).Value = Format(CDate(nDStart), "dd")
              .Offset(0, -1).Value = CDate(nDStart)
            End With
            nRow = nRow + 1
            nDStart = nDStart + 1
          Next
        Next j
        nLR = .Cells(Rows.Count, 20).End(xlUp).Row
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=Range( _
            "T2:T" & nLR), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
            xlSortNormal
        With .Sort
            .SetRange Range("P1:Z" & nLR)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
      End With
      On Error GoTo 0
      nStop = Timer
    CompleteAllDate_Error:
      
      If Err.Number <> 0 Then
        MsgBox "Error: " & Err.Description, vbCritical, "ERRORE"
      End If
    
      Set rngFr = Nothing
      Set rngTo = Nothing
      Set wsTrg = Nothing
      Set wb = Nothing
        
      With Application
        .Calculation = bCalc
        .ScreenUpdating = True
      End With
      MsgBox "finito in " & nStop - nStart
    
    End Sub 'CompletaAllDate
    [/CODE]


  • di GaBo (utente non iscritto) data: 26/12/2016 13:36:38

    Ragazzi, soluzioni spettacolari! Scossa, anche la Sua macro opera in memoria anzichè sul foglio? Sono alle prime armi in programmazione VBA e vorrei approfondire questa modalità perchè vedo che risolve il problema della lentezza esecuzione macro. Ne ho diverse e vorrei imparare a sfruttare questa possibilità. Quale argomento dovrei cercare per imparare a programmare utilizzando la memoria? Grazie

    Ho provato entrambe le macro:
    quella di Scossa impiega 0,54 sec, quella di Patel 3,71 sec. Patel Le stavo scrivendo, prima che arrivasse il post di Scossa, che la Sua macro, cambia la formattazione della colonna "V" e "Z". Nella colonna "V" a volte ho delle etichette "Mar02", dopo l'esecuzione diventano 02-mar. Nella colonna "Z" invece i numeri che hanno davanti lo "0" , a fine esecuzione lo perdono.
    La macro di Scossa, invece, ho visto che mantiene la formattazione originale e va a riempire anche i campi della colonna PQRS. Grazie mille ad entrambi, lavoro formidabile! Approfitto per fare gli auguri di buone feste e i migliori auspici per il nuovo anno! Grazie, GaBo


  • di patel data: 26/12/2016 14:06:43

    Quella di Scossa non operwa in memoria, non usa le matrici, aggiunge in fondo alla tabella originale solo le righe mancanti, poi riordina tutta la tabella.
    E' veramente geniale.