| | Post: 1.872 | Registrato il: 03/04/2013
| Utente Veteran | Excel 2000 - 2013 | | OFFLINE | |
|
  30/05/2015 19:19 | |
Buona sera.
Ecco il Codice:
Option Explicit
Sub Aggiorna()
Dim sh As Worksheet, sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, sh4 As Worksheet
Dim NRCS As Long, NRC As Long
Set sh = ActiveSheet
Set sh1 = ThisWorkbook.Sheets("Foglio1")
Set sh2 = ThisWorkbook.Sheets("Foglio2")
Set sh3 = ThisWorkbook.Sheets("Foglio3")
Set sh4 = ThisWorkbook.Sheets("Foglio4")
NRCS = sh1.Range("A" & Rows.Count).End(xlUp).Row
If NRCS < 2 Then NRCS = 2
sh1.Range("A2:C" & NRCS).Clear
NRCS = sh2.Range("A" & Rows.Count).End(xlUp).Row
If NRCS < 2 Then NRCS = 2
sh2.Range("A2:C" & NRCS).Clear
NRCS = sh3.Range("A" & Rows.Count).End(xlUp).Row
If NRCS < 2 Then NRCS = 2
sh3.Range("A2:C" & NRCS).Clear
NRCS = sh4.Range("A" & Rows.Count).End(xlUp).Row
If NRCS < 2 Then NRCS = 2
sh4.Range("A2:C" & NRCS).Clear
NRC = 2
Do While Cells(NRC, 1).Value > ""
If Mid(Cells(NRC, 1).Value, 7, 2) = "09" Or Mid(Cells(NRC, 1).Value, 7, 2) = "10" Then
NRCS = sh4.Range("A" & Rows.Count).End(xlUp).Row + 1
Range(Cells(NRC, 1), Cells(NRC, 3)).Copy sh4.Cells(NRCS, 1)
End If
If Left(Cells(NRC, 1).Value, 3) = "RTO" Then
If Mid(Cells(NRC, 1).Value, 7, 2) > 28 And Mid(Cells(NRC, 1).Value, 7, 2) < 33 Then
NRCS = sh1.Range("A" & Rows.Count).End(xlUp).Row + 1
Range(Cells(NRC, 1), Cells(NRC, 3)).Copy sh1.Cells(NRCS, 1)
End If
End If
If Left(Cells(NRC, 1).Value, 3) = "RTO" Then
If Mid(Cells(NRC, 1).Value, 7, 2) = 33 Then
NRCS = sh2.Range("A" & Rows.Count).End(xlUp).Row + 1
Range(Cells(NRC, 1), Cells(NRC, 3)).Copy sh2.Cells(NRCS, 1)
End If
End If
If Left(Cells(NRC, 1).Value, 3) = "RPO" Then
NRCS = sh3.Range("A" & Rows.Count).End(xlUp).Row + 1
Range(Cells(NRC, 1), Cells(NRC, 3)).Copy sh3.Cells(NRCS, 1)
End If
NRC = NRC + 1
Loop
Cells(NRC, 1).Select
Set sh = Nothing
Set sh1 = Nothing
Set sh2 = Nothing
Set sh3 = Nothing
Set sh4 = Nothing
End Sub
Questi i commenti; sono a parte in quanto, se inseririti a commento nel Codice, molto probabilmente, avrebbero creato problemi di leggibilità.
Option Explicit
Sub Aggiorna()
Dim sh As Worksheet, sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, sh4 As Worksheet
Dim NRCS As Long, NRC As Long
>>> Gestione e definizione delle Varialbili <<<
Set sh = ActiveSheet
Set sh1 = ThisWorkbook.Sheets("Foglio1")
Set sh2 = ThisWorkbook.Sheets("Foglio2")
Set sh3 = ThisWorkbook.Sheets("Foglio3")
Set sh4 = ThisWorkbook.Sheets("Foglio4")
NRCS = sh1.Range("A" & Rows.Count).End(xlUp).Row
If NRCS < 2 Then NRCS = 2
sh1.Range("A2:C" & NRCS).Clear
NRCS = sh2.Range("A" & Rows.Count).End(xlUp).Row
If NRCS < 2 Then NRCS = 2
sh2.Range("A2:C" & NRCS).Clear
NRCS = sh3.Range("A" & Rows.Count).End(xlUp).Row
If NRCS < 2 Then NRCS = 2
sh3.Range("A2:C" & NRCS).Clear
NRCS = sh4.Range("A" & Rows.Count).End(xlUp).Row
If NRCS < 2 Then NRCS = 2
sh4.Range("A2:C" & NRCS).Clear
NRC = 2
>>> Valori attribuiti alle Varialbili <<<
Option Explicit
Do While Cells(NRC, 1).Value > ""
If Mid(Cells(NRC, 1).Value, 7, 2) = "09" Or Mid(Cells(NRC, 1).Value, 7, 2) = "10" Then
NRCS = sh4.Range("A" & Rows.Count).End(xlUp).Row + 1
Range(Cells(NRC, 1), Cells(NRC, 3)).Copy sh4.Cells(NRCS, 1)
End If
If Left(Cells(NRC, 1).Value, 3) = "RTO" Then
If Mid(Cells(NRC, 1).Value, 7, 2) > 28 And Mid(Cells(NRC, 1).Value, 7, 2) < 33 Then
NRCS = sh1.Range("A" & Rows.Count).End(xlUp).Row + 1
Range(Cells(NRC, 1), Cells(NRC, 3)).Copy sh1.Cells(NRCS, 1)
End If
End If
If Left(Cells(NRC, 1).Value, 3) = "RTO" Then
If Mid(Cells(NRC, 1).Value, 7, 2) = 33 Then
NRCS = sh2.Range("A" & Rows.Count).End(xlUp).Row + 1
Range(Cells(NRC, 1), Cells(NRC, 3)).Copy sh2.Cells(NRCS, 1)
End If
End If
If Left(Cells(NRC, 1).Value, 3) = "RPO" Then
NRCS = sh3.Range("A" & Rows.Count).End(xlUp).Row + 1
Range(Cells(NRC, 1), Cells(NRC, 3)).Copy sh3.Cells(NRCS, 1)
End If
NRC = NRC + 1
Loop
>>> Ciclo di verifica delle condizioni <<<
Set sh = Nothing
Set sh1 = Nothing
Set sh2 = Nothing
Set sh3 = Nothing
Set sh4 = Nothing
>>> Annullo delle variabili per liberare le Risorse <<<
Per quanto concerne, l'Evento "Worksheet_Change", si tratta solo di definire quando farlo intervenire.
Una volta testata la Procedura, è possibile inserirla, opportunamente modificata, direttamente nell'Evento "Worksheet_Change"
Per quanto concerne, la velocità di esecuzione, si tratta di capire quanti Record devono essere gestiti; se è una quantità ragionevole, va bene il Codice, proposto.
Se la quantità di Record è rilevante, si potrebbe pensare a due Colonne d'appoggio nelle quali registrare, in automatico:
- il NomeFoglio nel quale è stato registrato il Record
- la Riga nella quale è stato registrato il Record
In questo modo, si potrà intervenire con una gestione più razionale di Nuovi Record e/o Record modificati.
Buon fine settimana.
Giuseppe
Windows XP - Excel 2000
Windows 10 - Excel 2013 |