Sì in fase di lavoro sulla cartella quella macro (quella che ho postato) va assolutamente disabilitata perchè rende troppo difficoltoso operare e sicuramente si sbaglia
Va bene solo ed esclusivamente per file terminati, protetti da pass e che sono destinati a data entry in poche celle modificabili, come appunto nel mio caso, in cui peraltro le celle modificabili sono quasi tutte soggette a convalida dati quindi una copia casuale restituisce errore.
Inoltre per impedire di cambiare le formattazioni condizionali, sempre a foglio terminato, è utile impedire la funzione di trascinamento.
---
Aggiungo questo codice collegato a un pulsante nel foglio di origine, che mi copia i valori presenti in B:J a partire dalla riga 21 (più la riga 20 di intestazione) se appartengono all'anno precedente (date in colonna B) in un nuovo foglio che prende la denominazione dell'anno precedente
Poi nel foglio di origine cancella i valori copiati (a parte gli ultimi tre mesi dell'anno precedente tenuti come base di continuità ed esclusa la riga di intestazione), cancellando anche una colonna in più che indica la data di registrazione della riga e che non era necessario copiare nel nuovo foglio
Il codice funziona perfettamente, anche se sicuramente può essere scritto meglio, ma essendo una cosa che va fatta una volta l'anno poco importa.
In testa ho messo un controllo che impedisce di attivare la macro se non si è raggiunto il 31 marzo del corrente anno (anno è preso dalla data odirna, presente in cella S16)
vorrei aggiungere un secondo if, che impedisce di attivare la macro se nel file è già presente un foglio denominato come il valore presente nella cella s17 (che contiene [=anno(oggi())-1] , quindi ad ora 2023)
ma non so come fare
una cosa così
+++++ IF nel file è presente un foglio denominato =Range("s17") Then GoTo finesub +++++++++
- Codice: Seleziona tutto
Sub Archivia()
If Date < DateSerial(Year(Range("S16")), 3, 31) Then GoTo finesub
+++++ IF nel file è presente un foglio denominato =Range("s17") Then GoTo finesub +++++++++
ActiveSheet.Unprotect ("password")
ActiveWorkbook.Unprotect ("password")
Sheets("Tracciabilità Carne").Select
Dim sel As Range
Dim i As Long
For i = 21 To Range("A" & Rows.Count).End(xlUp).Row
If Cells(i, 2) < DateSerial(Year(Range("S16")), 1, 1) Then
If sel Is Nothing Then
Set sel = Union(Cells(i, 2), Cells(i, 3), Cells(i, 4), Cells(i, 5), Cells(i, 6), Cells(i, 7), Cells(i, 8), Cells(i, 9), Cells(i, 10))
Else
Set sel = Union(sel, Cells(i, 2), Cells(i, 3), Cells(i, 4), Cells(i, 5), Cells(i, 6), Cells(i, 7), Cells(i, 8), Cells(i, 9), Cells(i, 10), Range("b20:j20"))
End If
End If
Next
sel.Select
Set sel = Nothing
selection.Copy
Dim szNomeFoglio As String
szNomeFoglio = Range("s17")
On Error GoTo MakeSheet
Sheets(szNomeFoglio).Activate
Exit Sub
MakeSheet:
Sheets.Add , Worksheets(Worksheets.Count)
ActiveSheet.Name = szNomeFoglio
Range("B2").Select
Columns("B:B").Select
selection.NumberFormat = "ddd dd/mm/yyyy"
Columns("A:A").ColumnWidth = 2
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").EntireColumn.AutoFit
Columns("E:E").EntireColumn.AutoFit
Columns("F:F").ColumnWidth = 70
Columns("G:G").ColumnWidth = 25
Columns("H:H").ColumnWidth = 40
Columns("I:I").EntireColumn.AutoFit
Columns("L:L").EntireColumn.AutoFit
Columns("j:j").EntireColumn.AutoFit
Columns("k:k").ColumnWidth = 2
Range("B2:J40000").Select
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$B$2:$J$40000"), , xlYes).Name = _
"TabellaRegistrazione"
Columns("B:B").Select
ActiveSheet.Unprotect
selection.Font.Bold = True
Columns("D:D").Select
selection.Font.Bold = True
Columns("J:J").Select
selection.Font.Bold = True
Range("a3").Select
ActiveWindow.FreezePanes = False
ActiveWindow.FreezePanes = True
ActiveSheet.ListObjects("TabellaRegistrazione").ShowTableStyleRowStripes = _
False
Cells.Select
ActiveSheet.Unprotect
With selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFiltering:=True
Range("b3").Select
Sheets("Tracciabilità Carne").Select
Dim sele As Range
Dim y As Long
For y = 21 To Range("A" & Rows.Count).End(xlUp).Row
If Cells(y, 2) < DateSerial((Year(Range("S16")) - 1), 10, 1) Then
If sele Is Nothing Then
Set sele = Union(Cells(y, 2), Cells(y, 3), Cells(y, 4), Cells(y, 5), Cells(y, 6), Cells(y, 7), Cells(y, 8), Cells(y, 9), Cells(y, 10), Cells(y, 11))
Else
Set sele = Union(sele, Cells(y, 2), Cells(y, 3), Cells(y, 4), Cells(y, 5), Cells(y, 6), Cells(y, 7), Cells(y, 8), Cells(y, 9), Cells(y, 10), Cells(y, 11))
End If
End If
Next
sele.Select
Set sel = Nothing
selection.ClearContents
finesub:
If Date > DateSerial(2025, 3, 31) Then 'protezione foglio
ActiveSheet.Protect Password:="wordpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
Else
ActiveSheet.Protect Password:="password", DrawingObjects:=True, Contents:=True, Scenarios:=True
End If
ActiveWorkbook.Protect Password:="password", Structure:=True, Windows:=False
ActiveWorkbook.Save
non ci avevo fatto caso!!! 