Esiste un modo per far si di copiare il contenuto delle prime 19 colonne (19 è lo step) ma solo per le righe per cui i valori ,nella colonna
C (ad esempio ) sia diverso da zero?
esempio con step solo 4 colonne:
esempio con 2 righe dalla colonna 1 alla 4 con Ci diverso da zero, 3 righe dalla colonna 5 alla 8 con ci diverso da zero:
adesso mi incolonna così:
a2 b2 c2 d2
a3 b3 c3 d3
0 0 0 0
0 0 0 0
e2 f2 g2 h2
e3 f3 g3 h3
e4 f4 g4 h4
0 0 0 0
0 0 0 0
vado quindi ad eliminare tutte le righe dove il valore della 3^ colonne =0
e diventa:
a2 b2 c2 d2
a3 b3 c3 d3
e2 f2 g2 h2
e3 f3 g3 h3
e4 f4 g4 h4
si può fare senza eliminare le celle dove il valore della 3^ colonna =0?
per velocizzare il calcolo?
- Codice: Seleziona tutto
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("ORDINI TOT")
Set Ws3 = Worksheets("PARTICOLARI")
Set Ws4 = Worksheets("COMMERCIALI")
UC1 = Ws1.Cells(2, Columns.Count).End(xlToLeft).Column
Sheets("ORDINI TOT").Range("A2").Resize(30000, 20).ClearContents
Sheets("PARTICOLARI").Range("A2").Resize(30000, 20).ClearContents
Sheets("COMMERCIALI").Range("A2").Resize(30000, 20).ClearContents
For CCR = 1 To UC1 - 5 Step 19
UR1 = Ws1.Range("A" & Rows.Count).End(xlUp).Row
Ws1.Range(Ws1.Cells(2, CCR), Ws1.Cells(UR1, CCR + 18)).Copy
Ws2.Select
UR2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
Range("A" & UR2).Select
ActiveSheet.Paste
Range("J:J,L:L,P:P,R:R").Select
Range("L1").Activate
Selection.NumberFormat = "d/m/yy;@"
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 Then Rows(RR2).Delete
Next RR2
UR2 = Ws2.Range("A" & Rows.Count).End(xlUp).Row
For RR2 = 2 To UR2
If Val(Ws2.Range("E" & RR2)) >= 1 And Val(Ws2.Range("E" & RR2)) <= 299999 And Val(Ws2.Range("E" & RR2)) <> 999 Then
Ws2.Range("A" & RR2 & ":s" & RR2).Copy Destination:=Ws3.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Else
Ws2.Range("A" & RR2 & ":s" & RR2).Copy Destination:=Ws4.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
End If
Next RR2
Ws2.Range("A1:s1").Copy Destination:=Ws3.Range("A1")
Ws2.Range("A1:s1").Copy Destination:=Ws4.Range("A1")
Application.Calculation = xlCalculationAutomatic '<<<< ripristina il calcolo
Application.ScreenUpdating = True '<<<< ripristina l'aggiornamento schermate
End Sub
grazie!