copia di dati da un file chiuso e elaborazione

[luca62]

RICHIESTA DI AIUTO,

Una decina di anni fa, i vari Anthony47, Flash etc mi hanno aiutato ( direi quasi fatto del tutto) un programmino utile su excel per la gestione di un elenco di dati esterni al file (che si aggiornavano via via). Via via ho modificato qualcosa ed ora , forse anche complice il passaggio dal vecchio excel 2007 ad excel 2016 mi da problemi, nel senso che si blocca oppure ci mette 15 minuti invece di 1 minuto ad aggiornare il tutto.Posto il file .
Mi si blocca qui dove evidenziato in rosso. allego link su We transfer del file esempio
https://we.tl/t-YIosVDfrQ5

Sub Compila()
Application.ScreenUpdating = False '<<<< evita l'aggiornamento schermate (sfarfallio)
Application.Calculation = xlManual '<<<< ferma il calcolo e velocizza la macro

Set Ws1 = Worksheets("RIEPILOGO ORDINI")
Set Ws2 = Worksheets("INCOLONNA")
Set Ws3 = Worksheets("PARTICOLARI")
Set Ws4 = Worksheets("COMMERCIALI")
UC1 = Ws1.Cells(1, Columns.Count).End(xlToLeft).Column
Ws2.Range("A2:Z10000").Clear
Ws3.Cells.Clear
Ws4.Cells.Clear
For CCR = 1 To UC1 - 4 Step 20
UR1 = Ws1.Range("A" & Rows.Count).End(xlUp).Row
Ws1.Range(Ws1.Cells(2, CCR), Ws1.Cells(UR1, CCR + 19)).Copy
Ws2.Select
UR2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
Range("A" & UR2).Select
ActiveSheet.Paste
Next CCR
UR2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row
For RR2 = UR2 To 1 Step -1
If Ws2.Range("C" & RR2).Value = 0 Or Ws2.Range("B" & RR2).Value = "Ins." Or Ws2.Range("C" & RR2).Value = "" Then Rows(RR2).Delete
If RR2 > 5 And Ws2.Range("B" & RR2).Value = "POS" Then Rows(RR2).Delete
Next RR2
UR2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row


For RR2 = 2 To UR2
If Val(Ws2.Range("D" & RR2)) >= 1 And Val(Ws2.Range("D" & RR2)) <= 199999 Then
Ws2.Range("A" & RR2 & ":E" & RR2).Copy Destination:=Ws3.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Else
Ws2.Range("A" & RR2 & ":E" & RR2).Copy Destination:=Ws4.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)

End If
Next RR2
Ws2.Range("A1:E1").Copy Destination:=Ws3.Range("A1")
Ws2.Range("A1:E1").Copy Destination:=Ws4.Range("A1")

Application.Calculation = xlCalculationAutomatic '<<<< ripristina il calcolo
Application.ScreenUpdating = True '<<<< ripristina l'aggiornamento schermate



End Sub

[Raffaele53]

>>> 1 minuto ad aggiornare il tutto
Nel foglio "RIEPILOGO ORDINI" ci sono 739 colonne diviso 19 = 40 x 152 righe = 5588 righe (Non credo sia fattibile in un solo minuto)

L'errore e dovuto al tatto che non riconosce in quale foglio debba eliminare Rows(RR2).Delete
Prova questo...

Codice: Seleziona tutto

Option Explicit
Sub Compila_BIS()
Dim Ws1 As Worksheet: Set Ws1 = Worksheets("RIEPILOGO ORDINI")
Dim Ws2 As Worksheet: Set Ws2 = Worksheets("INCOLONNA")
Dim Ws3 As Worksheet: Set Ws3 = Worksheets("PARTICOLARI")
Dim Ws4 As Worksheet: Set Ws4 = Worksheets("COMMERCIALI")
Dim Ur1 As Long, Ur2 As Long, CCR As Long, RR2 As Long, Uc1 As Long
    Application.ScreenUpdating = False  '<<<< evita l'aggiornamento schermate (sfarfallio)
    Application.Calculation = xlManual '<<<< ferma il calcolo e velocizza la macro
   
    Uc1 = Ws1.Cells(1, Columns.Count).End(xlToLeft).Column
    Ws2.Range("A2:Z10000").Clear
    Ws3.Cells.Clear
    Ws4.Cells.Clear
    For CCR = 1 To Uc1 - 4 Step 20
        Ur1 = Ws1.Range("A" & Rows.Count).End(xlUp).Row
        Ws1.Range(Ws1.Cells(2, CCR), Ws1.Cells(Ur1, CCR + 19)).Copy
        Ur2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
        Ws2.Range("A" & Ur2).PasteSpecial
    Next CCR
    Ur2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row
    For RR2 = Ur2 To 1 Step -1
        If Ws2.Range("C" & RR2).Value = 0 Or Ws2.Range("B" & RR2).Value = "Ins." Or Ws2.Range("C" & RR2).Value = "" Then Ws2.Rows(RR2).Delete
        If RR2 > 5 And Ws2.Range("B" & RR2).Value = "POS" Then Ws2.Rows(RR2).Delete
    Next RR2
    Ur2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row
    For RR2 = 2 To Ur2
        If Val(Ws2.Range("D" & RR2)) >= 1 And Val(Ws2.Range("D" & RR2)) <= 199999 Then
            Ws2.Range("A" & RR2 & ":E" & RR2).Copy Destination:=Ws3.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Else
            Ws2.Range("A" & RR2 & ":E" & RR2).Copy Destination:=Ws4.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        End If
    Next RR2
    Ws2.Range("A1:E1").Copy Destination:=Ws3.Range("A1")
    Ws2.Range("A1:E1").Copy Destination:=Ws4.Range("A1")

    Application.Calculation = xlCalculationAutomatic  '<<<< ripristina il calcolo
    Application.ScreenUpdating = True   '<<<< ripristina l'aggiornamento schermate
Set Ws1 = Nothing
Set Ws2 = Nothing
Set Ws3 = Nothing
Set Ws4 = Nothing
MsgBox "Fatto"
End Sub


[Raffaele53]

Provato in un nuovo files, molto più veloce mà non conosco il motivo.
Ho fatto un'aggiunta, ordino il foglio ed elimino tutte le righe della colonna C con zero tutte insieme. Riordino il tutto e faccio proseguire col Tuo codice . NB in foglio INCOLONNA, cella U1 scrivi =RIF.RIGA()

Codice: Seleziona tutto

Option Explicit
Sub Compila_BIS()
Dim Ws1 As Worksheet: Set Ws1 = Worksheets("RIEPILOGO ORDINI")
Dim Ws2 As Worksheet: Set Ws2 = Worksheets("INCOLONNA")
Dim Ws3 As Worksheet: Set Ws3 = Worksheets("PARTICOLARI")
Dim Ws4 As Worksheet: Set Ws4 = Worksheets("COMMERCIALI")
Dim Ur1 As Long, Ur2 As Long, CCR As Long, RR2 As Long, Uc1 As Long, Rg As Object
    Application.ScreenUpdating = False  '<<<< evita l'aggiornamento schermate (sfarfallio)
    Application.Calculation = xlCalculationManual '<<<< ferma il calcolo e velocizza la macro
    Ws2.Activate
    Uc1 = Ws1.Cells(1, Columns.Count).End(xlToLeft).Column
    Ur1 = Ws1.Range("A" & Rows.Count).End(xlUp).Row
    Ws2.Range("A2:Z10000").Clear
    Ws3.Cells.Clear
    Ws4.Cells.Clear
    For CCR = 1 To Uc1 - 4 Step 20
        Ws1.Range(Ws1.Cells(2, CCR), Ws1.Cells(Ur1, CCR + 19)).Copy
        Ur2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
        Ws2.Range("A" & Ur2).PasteSpecial
    Next CCR
    Ur2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row
'''''''''''''''''''aggiunta
    Application.Calculation = xlCalculationAutomatic
    Ws2.Range("U1").AutoFill Destination:=Ws2.Range("U1:U" & Ur2), Type:=xlFillDefault
    Application.Calculation = xlCalculationManual
    Ws2.Sort.SortFields.Clear
    Ws2.Sort.SortFields.Add2 Key:=Range("C2:C" & Ur2), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With Ws2.Sort
        .SetRange Range("A1:U" & Ur2)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Set Rg = Ws2.Range("C:C").Find(0, LookIn:=xlValues, LookAt:=xlWhole)
    If Rg Is Nothing Then
        MsgBox "nessuna riga da cancellare"
    Else
        CCR = Rg.Row
        Ws2.Rows(CCR & ":" & Ur2).Delete
    End If
    Ur2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row
    Ws2.Sort.SortFields.Clear
    Ws2.Sort.SortFields.Add2 Key:=Range("U2:U" & Ur2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Ws2.Sort
        .SetRange Range("A1:U" & Ur2)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
'''''''''''''''''''fine aggiunta
    For RR2 = Ur2 To 1 Step -1
        If Ws2.Range("C" & RR2).Value = 0 Or Ws2.Range("B" & RR2).Value = "Ins." Or Ws2.Range("C" & RR2).Value = "" Then Ws2.Rows(RR2).Delete
        If RR2 > 5 And Ws2.Range("B" & RR2).Value = "POS" Then Ws2.Rows(RR2).Delete
    Next RR2
    Ur2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row
    For RR2 = 2 To Ur2
        If Val(Ws2.Range("D" & RR2)) >= 1 And Val(Ws2.Range("D" & RR2)) <= 199999 Then
            Ws2.Range("A" & RR2 & ":E" & RR2).Copy Destination:=Ws3.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Else
            Ws2.Range("A" & RR2 & ":E" & RR2).Copy Destination:=Ws4.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        End If
    Next RR2
    Ws2.Range("A1:E1").Copy Destination:=Ws3.Range("A1")
    Ws2.Range("A1:E1").Copy Destination:=Ws4.Range("A1")

    Application.Calculation = xlCalculationAutomatic  '<<<< ripristina il calcolo
    Application.ScreenUpdating = True   '<<<< ripristina l'aggiornamento schermate
Set Ws1 = Nothing
Set Ws2 = Nothing
Set Ws3 = Nothing
Set Ws4 = Nothing
MsgBox "Fatto"
End Sub