Condividi:        

Macro sposta riga se data in colonna più vecchia di 3 mesi

Vuoi potenziare i tuoi documenti Word? Non sai come si fa una macro in Excel? Devi creare una presentazione in PowerPoint?
Oppure sei passato a OpenOffice e non sei sicuro di come lavorare al meglio?

Moderatori: Anthony47, Flash30005

Macro sposta riga se data in colonna più vecchia di 3 mesi

Postdi systemcrack » 02/08/24 14:51

Ciao a tutti, dopo la troppo breve pausa estiva ho ricominciato a lavorare anche sul progetto di cui ho già parlato qui.

Ma faccio un breve riassunto:
Ho un file chiamato protocollo.xlsm che utilizzo per protocollare le pratiche dell'ufficio.

Il file è composto da 4 fogli (SCHEDA, REGISTRO, CHIUSE, SCHEDATECNICA).

Nel foglio chiuse, vengono spostate tutte le pratiche una volta che queste sono chiuse e nella colonna J viene indicata la data dello spostamento/chiusura.

Ora per non appesantire troppo l'apertura del file, ma mantenendo comunque tutta la cronologia ho pensato di spostare le righe che riportano la data più vecchia di 3 mesi in un altro file che ho chiamato pratiche-chiuse.xlsm

Per cercare di fare questo ho aggiunto un modulo con il seguente codice:
Codice: Seleziona tutto
Sub MoveRows()
    Dim mydate As Date
    mydate = DateAdd("mm", -3, Date) 'Get the date 3 years ago from today
    Dim lastrow As Long
    lastrow = Sheets("CHIUSE").Cells(Rows.Count, "J").End(xlUp).Row 'Find the last row with data in column J of Sheet3
    Dim i As Long
    For i = lastrow To 1 Step -1 'Loop through rows from bottom to top
        If Sheets("CHIUSE").Cells(i, "J").Value < mydate Then 'If the date in column J is older than 3 years
            Sheets("CHIUSE").Rows(i).Cut 'Cut the row
            Workbooks("pratiche-chiuse").Sheets("Sheet1").Rows(Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row + 1).Insert Shift:=xlDown 'Insert the row into Sheet1
        End If
    Next i
End Sub

Che faccio richiamare nel Worksheet_Change "foglio CHIUSE" con un Call
Di seguito per completezza riporto il codice del foglio chiuse:
Codice: Seleziona tutto
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ur As Long
If Target.Count > 1 Then Exit Sub
'
If Target.Column = 9 Then               '9=I
    ur = Sheets("REGISTRO").Cells(Rows.Count, 1).End(xlUp).Row
    Target.Offset(0, 1).Value = Now                             ' ADD  Aggiunge Data di cambio status in J
    Target.Offset(0, 1).NumberFormat = "dd/mm/yyyy"             ' ADD formato
    If Right(Target.Value, 6) = "APERTA" Then
        Application.EnableEvents = False
            Range("A" & Target.Row & ":" & "J" & Target.Row).Copy Destination:=Sheets("REGISTRO").Cells(ur + 1, 1)      'MOD
            Target.EntireRow.Delete
        Application.EnableEvents = True
    End If
End If
Call MoveRows
ActiveCell.EntireRow.AutoFit
End Sub

Purtroppo quando faccio il test inserendo una riga con una data più vecchia Ricevo Errore di run-time: 5 su questa riga
Codice: Seleziona tutto
mydate = DateAdd("mm", -3, Date) 'Get the date 3 years ago from today

che avevo provato a modificare perchè la macro, (trovata online) originariamente faceva un controllo sui 3 anni.

Altro problema che rilevo aggiungendo questo codice è che se in foglio CHIUSE, cambio la dicitura da "CHIUSA" in "APERTA" la riga non ritorna nel foglio REGISTRO, come avveniva prima che aggiungessi il codice.
Avatar utente
systemcrack
Utente Senior
 
Post: 447
Iscritto il: 27/07/17 09:40

Sponsor
 

Re: Macro sposta riga se data in colonna più vecchia di 3 me

Postdi Anthony47 » 02/08/24 16:51

Come da help, la sintassi per aggiungere /sottrarre mesi e'
Codice: Seleziona tutto
DateAdd("m", NumeriMesi, DataIniziale)
https://learn.microsoft.com/it-it/office/vba/language/reference/user-interface-help/dateadd-function

Io pero' farei una piu' semplice
Codice: Seleziona tutto
mydate = Date-90
Lo so che non e' preciso ma ti crei meno problemi

Inoltre non la aggancerei alla WorksheetChange, piuttosto farei questa "potatura" la sera alla chiusura del lavoro
Avatar utente
Anthony47
Moderatore
 
Post: 19391
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Macro sposta riga se data in colonna più vecchia di 3 me

Postdi systemcrack » 08/08/24 08:37

Buongiorno Anthony, mi scuso per il ritardo nella risposta, ma sono stati giorni di fuoco al lavoro, ma non per le temperature e solo ora riesco a mettere in pratica i tuoi consigli.
Anthony47 ha scritto:Come da help, la sintassi per aggiungere /sottrarre mesi e'
Codice: Seleziona tutto
DateAdd("m", NumeriMesi, DataIniziale)
https://learn.microsoft.com/it-it/office/vba/language/reference/user-interface-help/dateadd-function

Io pero' farei una piu' semplice
Codice: Seleziona tutto
mydate = Date-90
Lo so che non e' preciso ma ti crei meno problemi

Si non cerco la perfezione anche se non è precisissimo va bene..
Dopo aver fatto qualche prova ora sembra funzionare egregiamente. ;)

Anthony47 ha scritto:Inoltre non la aggancerei alla WorksheetChange, piuttosto farei questa "potatura" la sera alla chiusura del lavoro

Ho pensato di far partire la macro all'apertura del file così che ogni mattina sia sempre aggiornato al giorno stesso.

Ora rimane solo un ultimo dilemma da trattare e cioè come gestire i files collegati alle pratiche chiuse definitivamente.
L'idea sarebbe di mantenere i files in un'altra cartella e il massimo della vita sarebbe che rimanessero collegati ai dati spostati nel nuovo file, ma immagino sia fantascienza.
Avatar utente
systemcrack
Utente Senior
 
Post: 447
Iscritto il: 27/07/17 09:40

Re: Macro sposta riga se data in colonna più vecchia di 3 me

Postdi systemcrack » 08/08/24 17:39

Vorrei fare questo perchè c'è la possibilità che vi siano contenziosi con i clienti anche a distanza di 1 anno, così facendo se dai piani alti chiedono un resoconto della pratica, il reparto sarà sempre in grado di generare una situazione/storico/cronologia dettagliati.
Avatar utente
systemcrack
Utente Senior
 
Post: 447
Iscritto il: 27/07/17 09:40

Re: Macro sposta riga se data in colonna più vecchia di 3 me

Postdi Anthony47 » 11/08/24 18:37

Ora rimane solo un ultimo dilemma da trattare e cioè come gestire i files collegati alle pratiche chiuse definitivamente.
L'idea sarebbe di mantenere i files in un'altra cartella e il massimo della vita sarebbe che rimanessero collegati ai dati spostati nel nuovo file, ma immagino sia fantascienza.
Dopo qualche giorno lontano dal PC ricordo ancora che la tua scelta fu di inserire un hyperlink sulle righe delle tue pratiche. Nel momento in cui "tagli" un record dal file protocollo.xlsm e lo incolli su pratiche-chiuse.xlsm, questo hyperlink viene inserito nel nuovo file. Ovviamente e' scritto in forma "solida" e se sposti il file il link rimane ma non potrà essere aperto.

Se vuoi spostare il file ma mantenere la possibilità di aprire il file devi automatizare tutto, cioe' lo spostamento del record, lo spostamento del file, l'aggiornamento del target. Non avendo tu un programmatore a portata di mano sono costretto a proporti una cosa completa, basata però (limitatamente al file di archiviazione) non sull'hyperlink ma sul doppioclick (credo che dall'inizio ti avessi sconsigliato l'hyperlink a favore del doppioclick
Pertanto
1) Modifichiamo la MoveRows come segue:
Codice: Seleziona tutto
Sub MoveRows()
Dim myDate As Date
Dim Lastrow As Long, mySplit, CFName As String, mCnt As Long
Dim HLCol, FCol, Chiuse As Worksheet, myNext As Long, DDest As String
'
HLCol = "E"                 '<<< La colonna che dovrebbe contenere l'hyperlink
FCol = "M"                  '<<< Colonna libera dove scrivere Data e nuovo nome file
DDest = "C:\PROVAY"         '<<< Il percorso in cui spostare i file
'
myDate = Date - 90          'Get the date 3 months ago from today
'
If Right(DDest, 1) <> "\" Then DDest = DDest & "\"
Set Chiuse = Workbooks("pratiche-chiuse.xlsm").Sheets("Sheet1")             'per comodità
Lastrow = Sheets("CHIUSE").Cells(Rows.Count, "J").End(xlUp).Row             'Last row with data in column J of Sheet3
'
For I = Lastrow To 1 Step -1                                                'Loop through rows from bottom to top
    If Sheets("CHIUSE").Cells(I, "J").Value < myDate Then                   'Date is older than threshold?
        myNext = Chiuse.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row   'Line to be compiled
        Sheets("CHIUSE").Rows(I).Cut Destination:= _
           Chiuse.Cells(myNext, "A").End(xlUp).Offset(1, 0)
        Sheets("CHIUSE").Rows(I).Delete
        If Chiuse.Cells(myNext, HLCol).Hyperlinks.Count > 0 Then            'check if Hyperlink
            Chiuse.Cells(myNext, FCol).Value = Date
            CFName = Chiuse.Cells(myNext, HLCol).Hyperlinks(1).Address      'Legge file di destinazione
            mySplit = Split("\ \" & CFName, "\", , vbTextCompare)
            Chiuse.Cells(myNext, FCol).Offset(0, 1).Value = DDest & mySplit(UBound(mySplit))    'Scrive il nuovo nome
            Name CFName As DDest & mySplit(UBound(mySplit))                 'Sposta files
            Chiuse.Cells(myNext, HLCol).Hyperlinks.Delete                   'Cancella hyperlink
        End If
        mCnt = mCnt + 1
    End If
Next I
Debug.Print "Record Archiviati: " & mCnt
MsgBox ("Record Archiviati: " & mCnt)
End Sub

Le righe marcate <<< vanno personalizzate come da commenti

2) Su file di archiviazione ("pratiche-chiuse.xlsm") inserisci questa macro di evento sul modulo vba del foglio Sheet1:
Codice: Seleziona tutto
'Dichiarazione in testa al modulo vba:
#If VBA7 Then
   Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
        ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, _
        ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr
#Else
   Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
        ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
        ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#End If



Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim FFName As String
'
Cancel = True
FFName = Target.Value
myPid = ShellExecute(vbNull, "Open", FFName, "", "", vbMaximizedFocus)
End Sub


In questo modo, la Sub MoveRows sposta i records dal file di lavoro a quello di archiviazione e memorizza data e nuovo nome del file collegato a quel record
Quando vuoi aprire il file di un record presente nel file di archivio devi fare doppioclick sul nome del file.
Ho previsto di memorizzare anche la data in cui l'operazione viene eseguita in modo da poter gestire eventuali modifiche al processo; tipo fino alla data A i file erano in C:\PrimoPercorso\Archivio; ma poi sono stati spostati su C:\SecondoPercorso. Usando la data come discriminante si potrebbe modificare, nella Sub Worksheet_BeforeDoubleClick, il nome del file da aprire.

Buon prova e riprova
Avatar utente
Anthony47
Moderatore
 
Post: 19391
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Macro sposta riga se data in colonna più vecchia di 3 me

Postdi systemcrack » 12/08/24 08:03

Ben ritrovato e buongiorno Anthony! :D
Anthony47 ha scritto:Se vuoi spostare il file ma mantenere la possibilità di aprire il file devi automatizare tutto, cioe' lo spostamento del record, lo spostamento del file, l'aggiornamento del target. Non avendo tu un programmatore a portata di mano sono costretto a proporti una cosa completa, basata però (limitatamente al file di archiviazione) non sull'hyperlink ma sul doppioclick (credo che dall'inizio ti avessi sconsigliato l'hyperlink a favore del doppioclick..)

Si ricordo perfettamente, ma non avevo capito come fare e lo ammetto, per semplicità/pigrizia mentale, avevo scelto la via che mi era più chiara/semplice.
Ma se passato questo periodo estivo e se avrai tempo e voglia, vorrei approfondirlo.

Riguardo ai codici che mi hai passato se gli hyperlink fossero su più colonne?
Cioè se in ogni riga ci fossero 3 collegamenti (colonne A - E -G)?
Se alcuni collegamenti sono a file word invece che pdf funziona comunque?
Avatar utente
systemcrack
Utente Senior
 
Post: 447
Iscritto il: 27/07/17 09:40

Re: Macro sposta riga se data in colonna più vecchia di 3 me

Postdi systemcrack » 12/08/24 09:46

Abbi pazienza Anthony, ma anche io sono stato lontano dal pc e mi sono un pò perso nel relax estivo.
Purtroppo però è questo il momento migliore per apportare modifiche e poi testarle, perciò sto obbligando il mio cervello a "ritornare in carreggiata" :roll: :lol:

Allora per riepilogare l'evoluzione del file:
Per via della molteplicità delle istruzioni che riceviamo, che non hanno uno standard e per cercare di aumentare il valore di utilità dello schema, si è deciso di "collegare" i file in più colonne

-colonna A Pratica (file pratica in pdf) Q:\....\....\PRATICHE
-colonna D Cliente (eventuale file packing list pdf) Q:\....\....\PRATICHE
-colonna E Cat (file buono matrice in pdf) Q:\....\....\PRATICHE\BUONI MAMMA
-colonna G Istruzioni (file istruzioni aggiuntive in word) Q:\....\....\ISTRUZIONI

Quando le pratiche si chiudono perchè più vecchie di 3 mesi i percorsi cambierebbero così:

-colonna A Pratica (file pratica in pdf) Q:\....\....\PRATICHE-CHIUSE-DEFINITIVAMENTE
-colonna D Cliente (eventuale file packing list pdf) Q:\....\....\PRATICHE-CHIUSE-DEFINITIVAMENTE
-colonna E Cat (file buono matrice in pdf) Q:\....\....\PRATICHE-CHIUSE-DEFINITIVAMENTE\BUONI MAMMA
-colonna G Istruzioni (file istruzioni aggiuntive in word) Q:\....\....\PRATICHE-CHIUSE-DEFINITIVAMENTE\ISTRUZIONI
Avatar utente
systemcrack
Utente Senior
 
Post: 447
Iscritto il: 27/07/17 09:40

Re: Macro sposta riga se data in colonna più vecchia di 3 me

Postdi systemcrack » 12/08/24 13:40

Un'ultima cosa Anthony che mi sono dimenticato di scrivere.. non è detto che questi collegamenti vi siano in tutte e 4 le colonne.. cioè ci possono essere casi in cui una pratica ha un solo hyperlink, altri in cui ve ne possono essere 2 o 3 fino a 4.
Avatar utente
systemcrack
Utente Senior
 
Post: 447
Iscritto il: 27/07/17 09:40

Re: Macro sposta riga se data in colonna più vecchia di 3 me

Postdi Anthony47 » 12/08/24 14:29

Ah, ci sono piu' hyperlink...
Allora lavoriamo con un dizionario delle traduzioni (OldPath e NewPath, nel codice successivo), e la
vecchia Sub MoveRows diventa:
Codice: Seleziona tutto
Sub PraticheChiuse()
Dim myDate As Date, I As Long, J As Long, HLCells, NFName As String
Dim Lastrow As Long, CFName As String, mCnt As Long
Dim FCol, Chiuse As Worksheet, myNext As Long
Dim mySplit, OldPath(0 To 3), NewPath(0 To 3)
'
HLCells = Array("A", "D", "E", "G")             '<<< Le colonne che dovrebbero contenere hyperlink
OldPath(0) = "\PRATICHE\"                       '<<< Vecchi percorsi
OldPath(1) = "\PRATICHE\"
OldPath(2) = "\PRATICHE\BUONI MAMMA\"
OldPath(3) = "\ISTRUZIONI\"
NewPath(0) = "\PRATICHE-CHIUSE-DEFINITIVAMENTE\" '<<< Nuovi percorsi
NewPath(1) = "\PRATICHE-CHIUSE-DEFINITIVAMENTE\"
NewPath(2) = "\PRATICHE-CHIUSE-DEFINITIVAMENTE\BUONI MAMMA\"
NewPath(3) = "\PRATICHE-CHIUSE-DEFINITIVAMENTE\ISTRUZIONI\"
'
FCol = "M"                                      '<<< Colonna libera dove scrivere Data e...
                                                ' ... a seguire gli N nuovi nome file
'
myDate = Date - 90          'Get the date 3 months ago from today
'
Set Chiuse = Workbooks("pratiche-chiuse.xlsm").Sheets("Sheet1")             'per comodità
Lastrow = Sheets("CHIUSE").Cells(Rows.Count, "J").End(xlUp).Row             'Last row with data in column J of Sheet3
'
For I = Lastrow To 1 Step -1                                                'Loop through rows from bottom to top
    If Sheets("CHIUSE").Cells(I, "J").Value < myDate Then                   'Date is older than threshold?
        myNext = Chiuse.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row   'Line to be compiled
        Sheets("CHIUSE").Rows(I).Cut Destination:= _
           Chiuse.Cells(myNext, "A")
        Sheets("CHIUSE").Rows(I).Delete
        For J = 0 To UBound(HLCells)
            If Chiuse.Cells(myNext, HLCells(J)).Hyperlinks.Count > 0 Then            'check if Hyperlink
                Chiuse.Cells(myNext, FCol).Value = Date
                CFName = Chiuse.Cells(myNext, HLCells(J)).Hyperlinks(1).Address      'Legge file di destinazione
                NFName = Replace(CFName, OldPath(J), NewPath(J), , , vbTextCompare)
                Chiuse.Cells(myNext, FCol).Offset(0, 1 + J).Value = NFName           'Scrive il nuovo nome
                Debug.Print HLCells(J) & I, myNext, CFName, NFName
                Name CFName As NFName                                                'Sposta files
                Chiuse.Cells(myNext, HLCells(J)).Hyperlinks.Delete                   'Cancella hyperlink
            End If
        Next J
        mCnt = mCnt + 1
    End If
Next I
Debug.Print "Record Archiviati: " & mCnt
MsgBox ("Record Archiviati: " & mCnt)
End Sub

Controlla bene il contenuto delle celle marcate <<<, e assicurati che tutti i percorsi esistano nel tuo filesystem.

Sul file PRATICHE-CHIUSE.xlsm il codice non cambia; la Sub Worksheet_BeforeDoubleClick aprirà il file su cui si clicca usando l'applicazione impostata per quel tipo di file.
E' opportuno mettere le intestazioni alle colonne M:Q per ricordarsi che cosa rappresenta il file che si va ad aprire; se una riga non ha un certo hyperlink allora la cella del file rimarrà vuota.

Ps: la mia antipatia per gli hyperlink nasce dal fatto che l'indirizzo di link e' un "attributo" della cella, quindi piu' facile da perdere e piu' difficile da manipolare (rispetto al nome scritto nella cella usato poi con l'evento doppioclick)

EDIT:
Mancavano 2 "\" in NewPath, ho corretto
Avatar utente
Anthony47
Moderatore
 
Post: 19391
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Macro sposta riga se data in colonna più vecchia di 3 me

Postdi Anthony47 » 12/08/24 14:42

Attenzione, che ho modificato il codice dopo la pubblicazione del messaggio
Avatar utente
Anthony47
Moderatore
 
Post: 19391
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Macro sposta riga se data in colonna più vecchia di 3 me

Postdi systemcrack » 12/08/24 14:43

Ho fatto una prova e mi sembra che il risultato ottenuto integrando il tuo codice sia più che soddisfacente.
In pratica nell'ultima colonna che si indica viene aggiunto il percorso al file sul PC, ma non cliccabile (mi sta bene anche così).
Stavo ragionando che per non complicarsi troppo la vita gli allegati di ogni singola pratica, (sia che sia 1 che più di 1), chiusa potrebbero essere salvati in "Q:\....\....\PRATICHE-CHIUSE-DEFINITIVAMENTE\Relativo NR.DI PRATICA" così che ogni pratica abbia tutto in una relativa sottocartella archiviata.
Avatar utente
systemcrack
Utente Senior
 
Post: 447
Iscritto il: 27/07/17 09:40

Re: Macro sposta riga se data in colonna più vecchia di 3 me

Postdi systemcrack » 12/08/24 14:44

Anthony47 ha scritto:Attenzione, che ho modificato il codice dopo la pubblicazione del messaggio

Ok visto.

NB
Il messaggio precedente l'ho scritto senza avere visto i tuoi messaggi che hai scritto poco fa.
Avatar utente
systemcrack
Utente Senior
 
Post: 447
Iscritto il: 27/07/17 09:40

Re: Macro sposta riga se data in colonna più vecchia di 3 me

Postdi systemcrack » 12/08/24 16:03

Ho provato il tuo nuovo codice che ho messo giù così:
Codice: Seleziona tutto
Sub MoveRows()
Dim myDate As Date, I As Long, J As Long, HLCells, NFName As String
Dim Lastrow As Long, CFName As String, mCnt As Long
Dim FCol, Chiuse As Worksheet, myNext As Long
Dim mySplit, OldPath(0 To 3), NewPath(0 To 3)
'
HLCells = Array("A", "D", "E", "G")             '<<< Le colonne che dovrebbero contenere hyperlink
OldPath(0) = "Q:\SCANNERTRASPORTI\DOC UFF TRASPORTI\PRATICHE\"                       '<<< Vecchi percorsi
OldPath(1) = "Q:\SCANNERTRASPORTI\DOC UFF TRASPORTI\PRATICHE\"
OldPath(2) = "Q:\SCANNERTRASPORTI\DOC UFF TRASPORTI\PRATICHE\BUONI MAMMA\"
OldPath(3) = "Q:\SCANNERTRASPORTI\DOC UFF TRASPORTI\ISTRUZIONI\"
NewPath(0) = "Q:\SCANNERTRASPORTI\DOC UFF TRASPORTI\PRATICHE-CHIUSE-DEFINITIVAMENTE" '<<< Nuovi percorsi
NewPath(1) = "Q:\SCANNERTRASPORTI\DOC UFF TRASPORTI\PRATICHE-CHIUSE-DEFINITIVAMENTE"
NewPath(2) = "Q:\SCANNERTRASPORTI\DOC UFF TRASPORTI\PRATICHE-CHIUSE-DEFINITIVAMENTE\BUONI MAMMA\"
NewPath(3) = "Q:\SCANNERTRASPORTI\DOC UFF TRASPORTI\PRATICHE-CHIUSE-DEFINITIVAMENTE\ISTRUZIONI\"
'
FCol = "O"                                      '<<< Colonna libera dove scrivere Data e...
N(0) = "K"                                  ' ... a seguire gli N nuovi nome file
N(1) = "L"
N(2) = "M"
N(3) = "N"
'
myDate = Date - 90          'Get the date 3 months ago from today
'
Set Chiuse = Workbooks("pratiche-chiuse.xlsm").Sheets("CHIUSE")             'per comodità
Lastrow = Sheets("CHIUSE").Cells(Rows.Count, "J").End(xlUp).Row             'Last row with data in column J of Sheet3
'
For I = Lastrow To 1 Step -1                                                'Loop through rows from bottom to top
    If Sheets("CHIUSE").Cells(I, "J").Value < myDate Then                   'Date is older than threshold?
        myNext = Chiuse.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row   'Line to be compiled
        Sheets("CHIUSE").Rows(I).Cut Destination:= _
           Chiuse.Cells(myNext, "A")
        Sheets("CHIUSE").Rows(I).Delete
        For J = 0 To UBound(HLCells)
            If Chiuse.Cells(myNext, HLCells(J)).Hyperlinks.Count > 0 Then            'check if Hyperlink
                Chiuse.Cells(myNext, FCol).Value = Date
                CFName = Chiuse.Cells(myNext, HLCells(J)).Hyperlinks(1).Address      'Legge file di destinazione
                NFName = Replace(CFName, OldPath(J), NewPath(J), , , vbTextCompare)
                Chiuse.Cells(myNext, FCol).Offset(0, 1 + J).Value = NFName           'Scrive il nuovo nome
                Debug.Print HLCells(J) & I, myNext, CFName, NFName
                Name CFName As NFName                                                'Sposta files
                Chiuse.Cells(myNext, HLCells(J)).Hyperlinks.Delete                   'Cancella hyperlink
            End If
        Next J
        mCnt = mCnt + 1
    End If
Next I
Debug.Print "Record Archiviati: " & mCnt
'MsgBox ("Record Archiviati: " & mCnt)
End Sub

Ho mantenuto il nome della macro "Sub MoveRows", disattivato il messaggio a fine processo e cambiato la casella in cui comparirà la data.
Ora c'è una parte che non riesco a completare sebbene i tuoi consigli:
Codice: Seleziona tutto
FCol = "M"                                      '<<< Colonna libera dove scrivere Data e...
                                                ' ... a seguire gli N nuovi nome file


Ho provato più varianti:
Codice: Seleziona tutto
FCol = "O"                                      '<<< Colonna libera dove scrivere Data e...
NewPath(0) = "K"                                  ' ... a seguire gli N nuovi nome file
NewPath(1) = "L"
NewPath(2) = "M"
NewPath(3) = "N"


Oppure come nell'esempio prima ancora:
Codice: Seleziona tutto
FCol = "O"                                      '<<< Colonna libera dove scrivere Data e...
N(0) = "K"                                  ' ... a seguire gli N nuovi nome file
N(1) = "L"
N(2) = "M"
N(3) = "N"


oppure
Codice: Seleziona tutto
NFName(0) = "K"                                  ' ... a seguire gli N nuovi nome file
NFName(1) = "L"
NFName(2) = "M"
NFName(3) = "N"


In entrambi i casi non funziona ed è ovvio che io stia sbagliando il richiamo. :aaah
Avatar utente
systemcrack
Utente Senior
 
Post: 447
Iscritto il: 27/07/17 09:40

Re: Macro sposta riga se data in colonna più vecchia di 3 me

Postdi Anthony47 » 12/08/24 18:25

Ti ha tratto in inganno il commento che ho messo su due righe...
Devi indicare solo la prima colonna (quella in cui verra' scritta la data); le altre colonne sono quelle a sequire. Quindi se scrivi
Codice: Seleziona tutto
FCol = "O"
allora i nomi file verranno scritti in P, Q, R ed S

In NewPath (come in OldPath) le stringhe devono terminare con \ (ne mancano 2)
In piu' se in NewPath scrivi tutto il percorso allora non serve piu' OldPath ed e' meglio cambiare una riga come segue:
Codice: Seleziona tutto
'                NFName = Replace(CFName, OldPath(J), NewPath(J), , , vbTextCompare)   'TOGLI
                mySplit = Split(CFName, "\", , vbTextCompare)       '+++ Metti
                NFName = NewPath(J) & mySplit(UBound(mySplit))      '+++ Metti

Un ultimo dubbio riguarda l'uso della lettera per far riferimento a un server; sarebbe invece meglio identificare la risorsa usando la "Universal Naming Convention" (UNC), quindi nella forma \\Nome-Server\NomeAreaCondivisa\Percorso\SottoPercorso\EtcEtc
Ti provoco se dico che il tuo amministratore di rete dovrebbe darti al volo il nome unc della risorsa?
Avatar utente
Anthony47
Moderatore
 
Post: 19391
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Macro sposta riga se data in colonna più vecchia di 3 me

Postdi systemcrack » 12/08/24 22:47

In quest'ultima parte riguardo l'argomento UNC devo ammettere che mi cogli impreparato. Comunque riflettevo che sebbene i files siano su server sono all'interno della stessa cartella e tutti in un punto specifico del server.. credo che il NewPath e l'OldPath possano essere indicati come suggerivi tu pochi post sopra. Domani in ufficio farò delle prove e ti saprò dire.
Avatar utente
systemcrack
Utente Senior
 
Post: 447
Iscritto il: 27/07/17 09:40

Re: Macro sposta riga se data in colonna più vecchia di 3 me

Postdi systemcrack » 13/08/24 08:18

Buongiorno Anthony,
dopo aver inserito le modifiche il codice della macro risulta essere così composto:
Codice: Seleziona tutto
Sub MoveRows()
Dim myDate As Date, I As Long, J As Long, HLCells, NFName As String
Dim Lastrow As Long, CFName As String, mCnt As Long
Dim FCol, Chiuse As Worksheet, myNext As Long
Dim mySplit, OldPath(0 To 3), NewPath(0 To 3)
'
HLCells = Array("A", "D", "E", "G")             '<<< Le colonne che dovrebbero contenere hyperlink
OldPath(0) = "\PRATICHE\"                       '<<< Vecchi percorsi
OldPath(1) = "\PRATICHE\"
OldPath(2) = "\PRATICHE\BUONI MAMMA\"
OldPath(3) = "\PRATICHE\ISTRUZIONI\"
NewPath(0) = "\PRATICHE-CHIUSE-DEFINITIVAMENTE\" '<<< Nuovi percorsi
NewPath(1) = "\PRATICHE-CHIUSE-DEFINITIVAMENTE\"
NewPath(2) = "\PRATICHE-CHIUSE-DEFINITIVAMENTE\BUONI MAMMA\"
NewPath(3) = "\PRATICHE-CHIUSE-DEFINITIVAMENTE\ISTRUZIONI\"
'
FCol = "O"                                      '<<< Colonna libera dove scrivere Data e...
                                 ' ... a seguire gli N nuovi nome file

'
myDate = Date - 90          'Get the date 3 months ago from today
'
Set Chiuse = Workbooks("pratiche-chiuse.xlsm").Sheets("CHIUSE")             'per comodità
Lastrow = Sheets("CHIUSE").Cells(Rows.Count, "J").End(xlUp).Row             'Last row with data in column J of Sheet3
'
For I = Lastrow To 1 Step -1                                                'Loop through rows from bottom to top
    If Sheets("CHIUSE").Cells(I, "J").Value < myDate Then                   'Date is older than threshold?
        myNext = Chiuse.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row   'Line to be compiled
        Sheets("CHIUSE").Rows(I).Cut Destination:= _
           Chiuse.Cells(myNext, "A")
        Sheets("CHIUSE").Rows(I).Delete
        For J = 0 To UBound(HLCells)
            If Chiuse.Cells(myNext, HLCells(J)).Hyperlinks.Count > 0 Then            'check if Hyperlink
                Chiuse.Cells(myNext, FCol).Value = Date
                CFName = Chiuse.Cells(myNext, HLCells(J)).Hyperlinks(1).Address      'Legge file di destinazione
                NFName = Replace(CFName, OldPath(J), NewPath(J), , , vbTextCompare)
                Chiuse.Cells(myNext, FCol).Offset(0, 1 + J).Value = NFName           'Scrive il nuovo nome
                Debug.Print HLCells(J) & I, myNext, CFName, NFName
                Name CFName As NFName                                                'Sposta files
                Chiuse.Cells(myNext, HLCells(J)).Hyperlinks.Delete                   'Cancella hyperlink
            End If
        Next J
        mCnt = mCnt + 1
    End If
Next I
Debug.Print "Record Archiviati: " & mCnt
'MsgBox ("Record Archiviati: " & mCnt)
End Sub

Ho eseguito alcune prove e purtroppo c'è più di una cosa che non funziona:

1) ricevo un errore Run-Time'53'
Immagine

Immagine

2) I files collegati non vengono spostati e i nuovi percorsi non vengono indicati nelle celle successive a "o"

3) In ultimo mi sono accorto che in pratiche-chiuse.xlms in cui ho aggiunto nel modulo vba del Foglio1 (CHIUSE) il codice
Codice: Seleziona tutto
#If VBA7 Then
   Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
        ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, _ ...ecc. ecc.

viene evidenziato in rosso dal vba.. è normale?
Immagine

P.S.
Ho trovato gli indirizzi UNC grazie alla macro che restituisce l'indirizzo del file spostato ;)
Avatar utente
systemcrack
Utente Senior
 
Post: 447
Iscritto il: 27/07/17 09:40

Re: Macro sposta riga se data in colonna più vecchia di 3 me

Postdi systemcrack » 13/08/24 08:54

Allego i 2 file in questione così che tu possa toccare con mano il mio pessimo lavoro. :lol:
Avatar utente
systemcrack
Utente Senior
 
Post: 447
Iscritto il: 27/07/17 09:40

Re: Macro sposta riga se data in colonna più vecchia di 3 me

Postdi systemcrack » 13/08/24 13:51

Ok dopo diverse prove sembra io sia riuscito a giungere alla soluzione.. forse il problema dipendeva da un errata compilazione degli indirizzi delle cartelle di "destinazione" delle pratiche chiuse.
Quindi sono giunto a questo risultato:
Codice: Seleziona tutto
Sub MoveRows()
Dim myDate As Date, I As Long, J As Long, HLCells, NFName As String
Dim Lastrow As Long, CFName As String, mCnt As Long
Dim FCol, Chiuse As Worksheet, myNext As Long
Dim mySplit, OldPath(0 To 3), NewPath(0 To 3)
'
HLCells = Array("A", "D", "E", "G")             '<<< Le colonne che dovrebbero contenere hyperlink
OldPath(0) = "\PRATICHE\"                       '<<< Vecchi percorsi
OldPath(1) = "\PRATICHE\ISTRUZIONI\P.LIST\"
OldPath(2) = "\PRATICHE\BUONI MAMMA\"
OldPath(3) = "\PRATICHE\ISTRUZIONI\"
NewPath(0) = "\PRATICHE-CHIUSE-DEFINITIVAMENTE\" '<<< Nuovi percorsi
NewPath(1) = "\PRATICHE-CHIUSE-DEFINITIVAMENTE\ISTRUZIONI\P.LIST\"
NewPath(2) = "\PRATICHE-CHIUSE-DEFINITIVAMENTE\BUONI MAMMA\"
NewPath(3) = "\PRATICHE-CHIUSE-DEFINITIVAMENTE\ISTRUZIONI\"
'
FCol = "K"                                      '<<< Colonna libera dove scrivere Data e...
                                                ' ... a seguire gli N nuovi nome file
'
myDate = Date - 90          'Get the date 3 months ago from today
'
Set Chiuse = Workbooks("pratiche-chiuse.xlsm").Sheets("CHIUSE")             'per comodità
Lastrow = Sheets("CHIUSE").Cells(Rows.Count, "J").End(xlUp).Row             'Last row with data in column J of Sheet3
'
For I = Lastrow To 1 Step -1                                                'Loop through rows from bottom to top
    If Sheets("CHIUSE").Cells(I, "J").Value < myDate Then                   'Date is older than threshold?
        myNext = Chiuse.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row   'Line to be compiled
        Sheets("CHIUSE").Rows(I).Cut Destination:= _
           Chiuse.Cells(myNext, "A")
        Sheets("CHIUSE").Rows(I).Delete
        For J = 0 To UBound(HLCells)
            If Chiuse.Cells(myNext, HLCells(J)).Hyperlinks.Count > 0 Then            'check if Hyperlink
                Chiuse.Cells(myNext, FCol).Value = Date
                CFName = Chiuse.Cells(myNext, HLCells(J)).Hyperlinks(1).Address      'Legge file di destinazione
                NFName = Replace(CFName, OldPath(J), NewPath(J), , , vbTextCompare)
                Chiuse.Cells(myNext, FCol).Offset(0, 1 + J).Value = NFName           'Scrive il nuovo nome
                Debug.Print HLCells(J) & I, myNext, CFName, NFName
                Name CFName As NFName                                                'Sposta files
                Chiuse.Cells(myNext, HLCells(J)).Hyperlinks.Delete                   'Cancella hyperlink
            End If
        Next J
        mCnt = mCnt + 1
    End If
Next I
Debug.Print "Record Archiviati: " & mCnt
MsgBox ("Record Archiviati: " & mCnt)
End Sub

Ora quando la macro si attiva in colonna K aggiunge la data di spostamento e di seguito, sulla stessa riga, i percorsi per arrivare ai file allegati, ma se volessi togliere la data di spostamento? Cioè se non volessi che venisse riportata la data dello spostamento della pratica tra il file protocollo ed il file pratiche-chiuse?

C'è un'ultima sciocchezza che vorrei comprendere per il futuro e cioè quando i dati sulla riga del file protocollo/foglio CHIUSE (per intenderci lista pratiche chiuse fino a 90 gg) vengono tagliati ed incollati nel file pratiche-chiuse/ foglio CHIUSE alcune celle di quest'ultimo foglio perdono le "cornici".. non sono sicuro da cosa dipenda il problema.
Avatar utente
systemcrack
Utente Senior
 
Post: 447
Iscritto il: 27/07/17 09:40

Re: Macro sposta riga se data in colonna più vecchia di 3 me

Postdi systemcrack » 13/08/24 14:09

Ho notato che le celle che risultano senza formattazione sono le celle non copiate, ma che riportano l'indirizzo dei files, quindi credo che il punto in cui si debba agire sia questo:
Codice: Seleziona tutto
Chiuse.Cells(myNext, FCol).Offset(0, 1 + J).Value = NFName           'Scrive il nuovo nome
                Debug.Print HLCells(J) & I, myNext, CFName, NFName

Ma non saprei dire come :mmmh: :lol:
Avatar utente
systemcrack
Utente Senior
 
Post: 447
Iscritto il: 27/07/17 09:40

Re: Macro sposta riga se data in colonna più vecchia di 3 me

Postdi Anthony47 » 13/08/24 15:22

Il codice in rosso nel modulo vba che contiene la Sub BeforeDoubleClick e' normale (il codice e' sbagliato per il tuo vba, ma tu sei con VBA7 e quelle istruzioni non vengono compilate)

Se hai trovato l'indirizzo UNC allora io lo userei per indicare la posizione di archiviazione: indicherei tutto il percorso con UNC in NewPath (eliminando OldPath) e modificando la macro come detto qui: viewtopic.php?f=26&t=113405&p=667130#p667123
Teoricamente l'UNC e' piu' stabile nel tempo



C'è un'ultima sciocchezza che vorrei comprendere per il futuro e cioè quando i dati sulla riga del file protocollo/foglio CHIUSE (per intenderci lista pratiche chiuse fino a 90 gg) vengono tagliati ed incollati nel file pratiche-chiuse/ foglio CHIUSE alcune celle di quest'ultimo foglio perdono le "cornici".. non sono sicuro da cosa dipenda il problema.

Ho notato che le celle che risultano senza formattazione sono le celle non copiate, ma che riportano l'indirizzo dei files, quindi credo che il punto in cui si debba agire sia questo:
Codice: Seleziona tutto
    Chiuse.Cells(myNext, FCol).Offset(0, 1 + J).Value = NFName           'Scrive il nuovo nome


Non ho capito se stai parlando del file che contiene il foglio CHIUSE (quello da cui "tagli" i record vecchi per spostarli sul file pratiche-chiuse.xlsm) o del file pratiche-chiuse.xlsm

A parte questo dubbio, se alleghi uno screenshot del fenomeno magari riesco a farmi un'idea
Avatar utente
Anthony47
Moderatore
 
Post: 19391
Iscritto il: 21/03/06 16:03
Località: Ivrea

Prossimo

Torna a Applicazioni Office Windows


Topic correlati a "Macro sposta riga se data in colonna più vecchia di 3 mesi":


Chi c’è in linea

Visitano il forum: Nessuno e 6 ospiti