Moderatori: Anthony47, Flash30005
Sub Compila()
Set Ws1 = Worksheets("RIEPILOGO PART-COMM")
Set Ws2 = Worksheets("INCOLONNA")
Set Ws3 = Worksheets("PARTICOLARI")
Set Ws4 = Worksheets("COMMERCIALI")
UC1 = Ws1.Cells(1, Columns.Count).End(xlToLeft).Column
Ws2.Cells.Clear
Ws3.Cells.Clear
Ws4.Cells.Clear
For CCR = 1 To UC1 - 4 Step 5
UR1 = Ws1.Range("A" & Rows.Count).End(xlUp).Row
Ws1.Range(Ws1.Cells(1, CCR), Ws1.Cells(UR1, CCR + 4)).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 = 1 To UR2
If Val(Ws2.Range("D" & RR2)) <= 999999 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")
End Sub
Set Ws1 = Worksheets("RIEPILOGO PART-COMM ")
Sub Compila()
Application.ScreenUpdating = False '<<<< evita l'aggiornamento schermate (sfarfallio)
Application.Calculation = xlManual '<<<< ferma il calcolo e velocizza la macro
Set Ws1 = Worksheets("RIEPILOGO PART-COMM")
Set Ws2 = Worksheets("INCOLONNA")
Set Ws3 = Worksheets("PARTICOLARI")
Set Ws4 = Worksheets("COMMERCIALI")
UC1 = Ws1.Cells(1, Columns.Count).End(xlToLeft).Column
Ws2.Cells.Clear
Ws3.Cells.Clear
Ws4.Cells.Clear
For CCR = 1 To UC1 - 4 Step 5
UR1 = Ws1.Range("A" & Rows.Count).End(xlUp).Row
Ws1.Range(Ws1.Cells(1, CCR), Ws1.Cells(UR1, CCR + 4)).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 = 1 To UR2
If Val(Ws2.Range("D" & RR2)) >= 1 And Val(Ws2.Range("D" & RR2)) <= 999999 Then
Ws2.Range("A" & RR2 & ":E" & RR2).Copy Destination:=Ws3.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Else
If Val(Ws2.Range("D" & RR2)) > 999999 Then 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
Else '<<<< esistente
Ws2.Range("A" & RR2 & ":E" & RR2).Copy Destination:=Ws4.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) '<<<< modificata
End If '<<<< esistente
Torna a Applicazioni Office Windows
Ordinare colonne sulla stessa riga se stesso contenuto Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 10 |
Inserire dati filtrati da 2 file ad un terzo file Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 14 |
Stabilire righe e colonne da mostrare a schermo Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 10 |
Visitano il forum: Nessuno e 9 ospiti