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

[systemcrack]

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.

[Anthony47]

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

[systemcrack]

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.

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.

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.

[systemcrack]

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.

[Anthony47]

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

[systemcrack]

Ben ritrovato e buongiorno Anthony!

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?

[systemcrack]

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"

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

[systemcrack]

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.

[Anthony47]

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

[Anthony47]

Attenzione, che ho modificato il codice dopo la pubblicazione del messaggio

[systemcrack]

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.

[systemcrack]

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.

[systemcrack]

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.

[Anthony47]

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?

[systemcrack]

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.

[systemcrack]

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'




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?


P.S.
Ho trovato gli indirizzi UNC grazie alla macro che restituisce l'indirizzo del file spostato

[systemcrack]

Allego i 2 file in questione così che tu possa toccare con mano il mio pessimo lavoro.

[systemcrack]

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.

[systemcrack]

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

[Anthony47]

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