Spostamento di file in una cartella di cui è nota solo una parte del nome

[GhidoPartecipante Ghido]

Ciao a tutti...

sto cercando il sistema per spostare tutti i file contenuti in una cartella.

La destinazione sarà un'altra cartella di cui conosco (a priori) solo la prima parte del nome (nel codice allegato è ipotizzato nella cella A1).

Questa parte di stringa è comunque univoca, quindi, in via teorica, ("A1")&"*" dovrebbe individuare una ed una sola cartella... ma come posso farlo digerire a VBA?

Grazie

Sub MoveFile()

'
'Dichiarazione variabili
    Dim AllFile As String
    Dim FromPath As String
    Dim ToPath As String
    Dim FSO As Object
    
    AllFile = "C:\Users\lghidini\Downloads\*.*"
    FromPath = "C:\Users\lghidini\Downloads"
    ToPath = "\\NAS2000\Prog_Svil_Terr\settore pianificazione SIT\servizio pianificazione\Istruttorie paesaggistiche\- COMUNI NON IDONEI\" & Range("A1") & "*"
    Set FSO = CreateObject("scripting.filesystemobject")
       
'Arresto per elementi mancanti
        If Len(Dir$(AllFile)) = 0 Then
            MsgBox Prompt:="File mancanti.", Buttons:=vbCritical, Title:="Attenzione!"
            Exit Sub
        End If
        
        If FSO.FolderExists(FromPath) = False Then
            MsgBox FromPath & " non esiste!"
            Exit Sub
        End If
        
        If FSO.FolderExists(ToPath) = False Then
            MsgBox ToPath & " non esiste!"
            Exit Sub
        End If

'Copia dei file da Download alla cartella della pratica
    
    FSO.Copyfolder Source:=FromPath, Destination:=ToPath

'Eliminazione file da Download
    If Len(Dir$(AllFile)) > 0 Then
        Kill AllFile
    End If

End Sub

Ghido

[GiuseppeMNPartecipante GiuseppeMN Karma: 19 pts]

Buona sera, @ghido.

@ghido, chiede:

Spostamento di file in una cartella di cui è nota solo una parte del nome.

Per quanto ne so non credo sia possibile intercettare una Cartella (Directory) senza il nome completo.
Quello che posso proporti è la possibilità di scegliere dall'elenco delle Subdirectories all'interno di una Cartella la Cartella da inserire in Cella "A1".

A disposizione.

Giuseppe

[patelModeratore patel Karma: 51 pts]

l'asterisco non funziona con le cartelle

[GhidoPartecipante Ghido]

Ciao @giuseppemn, 

grazie per il consiglio. ho provato a metterlo in pratica!

Io sono decisamente un neofita, e quindi chiedo conferma a te... e agli altri esperti del forum sulla accettabilità del mio risultato, che ti riporto!

Inoltre chiedo un'altra cosa: ho impostato .InitialFileName con il percorso da cui deve partire la ricerca. Che voi sappiate, in msoFileDialogFolderPicker è possibile impostare automaticamente anche un filtro di ricerca per le sottocartelle presenti nel percorso? (spesso devo ricercarla in un archivio di alcune migliaia)

Grazie ancora per i preziosissimi consigli

Sub MoveFile()

'
'Dichiarazione variabili
    Dim RootPath As String
    Dim CodPrat As String
    Dim FromPath As String
    Dim ToPath As String
    Dim AllFile As String
    Dim NewPath As String
    Dim DiaFile As FileDialog
    Dim FSO As Object
    
    RootPath = "C:\Users\lghidini\Desktop\"
    CodPrat = Range("A1").Value
    FromPath = RootPath & "\Prova"
    ToPath = RootPath & CodPrat
    AllFile = FromPath & "\*.*"
    Set FSO = CreateObject("scripting.filesystemobject")

'Arresto per elementi mancanti
        If Len(Dir$(AllFile)) = 0 Then
            MsgBox Prompt:="File mancanti.", Buttons:=vbCritical, Title:="Attenzione!"
            Exit Sub
        End If
        
        If FSO.FolderExists(FromPath) = False Then
            MsgBox FromPath & " non esiste!"
            Exit Sub
        End If
        
'Copia dei file da Download alla cartella della pratica
        If FSO.FolderExists(ToPath) = True Then
            FSO.Copyfolder Source:=FromPath, Destination:=ToPath
        ElseIf FSO.FolderExists(ToPath) = False Then
            Set DiaFile = Application.FileDialog(msoFileDialogFolderPicker)
            With DiaFile
                .Title = "Seleziona nuovo percorso"
                .InitialFileName = "C:\Users\lghidini\Desktop\"
                .AllowMultiSelect = False
                .Show
            End With
            If DiaFile.SelectedItems.Count > 0 Then
                NewPath = DiaFile.SelectedItems(1)
                FSO.Copyfolder Source:=FromPath, Destination:=NewPath
                ElseIf DiaFile.SelectedItems.Count = 0 Then
                MsgBox Prompt:="Nessun percorso selezionato", Buttons:=vbCritical, Title:="Attenzione!"
                Exit Sub
            End If
        End If

'Eliminazione file da Download
    If Len(Dir$(AllFile)) > 0 Then
        Kill AllFile
    End If

End Sub

 

 

 

 

[GiuseppeMNPartecipante GiuseppeMN Karma: 19 pts]

Buon pomeriggio @ghido;
credo dovrò analizzare meglio il tuo Codice VBA, da un primo sguardo mi sembra ci sia qualche cosa che non mi convince.
Il Codice che ho impostato, solo per la scelta della Cartella di destinazione scelta è:

Option Explicit

Sub cerca_file_da_caricare()
Dim fd As FileDialog
Dim percorso As Variant
Dim cartella As String

Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.InitialFileName = "C:\Users\lghidini\Desktop\"
.Title = "Sfoglia cartelle"
.ButtonName = "OK"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewDetails
.Show
For Each percorso In .SelectedItems
cartella = percorso
Next
End With
Cells(1, 1).Value = cartella
End Sub

Appena posso cerco di adattalo alla tua richiesta ma temo dovrò rimadare l'analisi a domani.

 

Giuseppe

[Giuseppe Giuseppe]

Buona giornata, @ghido;
nel tuo Codice VBA mi genera un errore in:
FSO.CopyFolder Source:=FromPath, Destination:=NewPath
Molto probabilmente manca l'estensione dei File da spostare; in ogni caso, perdonami, ho preferito riscrivere il Codice completo.

Option Explicit

Sub Sposta_Files()
On Error GoTo 10
Application.ScreenUpdating = False
Const Origine As String = "C:\Prova" ' Cartella nella quale selezionare la Cartella di destinazione.
Const Ext As String = "*.*" ' Dedinisce l'estensione dei File da valutare.
Dim Pth As String
Dim DPth As String
Dim Fd As FileDialog
Dim Percorso As Variant
Dim Cartella As String
Dim FSO As Object

Set Fd = Application.FileDialog(msoFileDialogFolderPicker)
With Fd
.InitialFileName = Origine & "\"
.Title = "Sfoglia cartelle"
.ButtonName = "OK"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewDetails
.Show
For Each Percorso In .SelectedItems
Cartella = Percorso
Next
End With
Cells(1, 1).Value = Cartella

Pth = "C:\Prova\Nuovo\" ' NomeFile dal quale spostare i File
DPth = Cells(1, 1).Value

If Right(Pth, 1) <> "\" Then
End If

Set FSO = CreateObject("scripting.filesystemobject")

If FSO.FolderExists(Pth) = False Then
MsgBox Pth & " Non esiste"
Exit Sub
End If

If FSO.FolderExists(DPth) = False Then
MsgBox DPth & " Non esiste"
Exit Sub
End If

FSO.CopyFile Source:=Pth & Ext, Destination:=DPth
Kill Pth & "\*.*"
MsgBox "File spostati da: " & Pth & " a: " & DPth
Set Fd = Nothing
Set FSO = Nothing
End
10:
MsgBox "La Procedura non è andata a buon fine."
Set Fd = Nothing
Set FSO = Nothing
Application.ScreenUpdating = True
End Sub

Il Codice è solo una bozza ma potrebbe essere uno spunto per migliorare la Procedura.
Come puoi ben vedere ho utilizzato le Costanti:
- Const Origine As String = "C:\Prova"
e
- Const Ext As String = "*.*"
In questo modo puoi definire la Cartella nella quale selezionare la Cartella di destinazione e l'estensione dei Files da spostare.

 

Giuseppe

[GhidoPartecipante Ghido]

Buongiorno @giuseppemn

grazie infinite per le dritte. Ho provato ad inserire il codice come parte di un'altra macro, e tutto funziona, ma se volessi tenerla come Sub a se stante, richiamandola all'interno di un'altra Sub, sarebbe possibile?
Cerco di schematizzarti qui sotto l'idea... e soprattutto il relativo problema: quando nella Sub CaricaFile riscontra un errore, vorrei che interrompesse sia la Sub secondaria sia quella principale, mentre, scritta così, interrompe solo la seconda e prosegue, ovviamente, con la prima!

Grazie di nuovo!!!

Sub Aggiorna()
'
'Prima parte di codice per aggiornamento dei dati di un Foglio
'....

    If Range("D23") <> "" Or Range("D35") <> "" Then
        Call CaricaFile
    End If
        
'Seconda parte di codice per aggiornamento dei dati di un Foglio
'....
        
End Sub

Sub CaricaFile()

'Il codice per lo spostamento dei file (di cui ai messaggi precedenti)
'comprensivo di criteri di arresto in caso di elementi mancanti (ad es...
            If Len(Dir$(AllFile)) = 0 Then
                MsgBox Prompt:="File mancanti.", Buttons:=vbCritical, Title:="Attenzione!"
                Exit Sub
            End If

'... e il resto del codice di spostamento

End Sub

[Giuseppe Giuseppe]

Buona giornata, @ghido;
non mi è molto chiara la tua richiesta e senza un dialogo diretto credo veramente complicato cercare di risolvere.
Considera che dopo le ultime modifiche alla struttura di Forum ho dovuto inviare tre risposte prima di vedere concretizzarsi la mia proposta.

Credo mi fermerò qui ma ti lascio in buone anzi ottime mani.

 

Giuseppe

 

[GhidoPartecipante Ghido]

Grazie infinite @giuseppemn...

probabilmente stavamo scrivendo contemporaneamente (per questo nel mio ultimo codice è richiamato un criterio di arresto superato dal tuo più raffinato "On Error GoTo 10"...

Forse questo potrebbe risolvere anche il problema del Call (ora ci provo).

Il tuo aiuto è stato preziosissimo!!!

Ghido

[Giuseppe Giuseppe]

Buona giornata, @ghido;
anche a beneficio degli Utenti interessati a questa Discussione, consentimi solo una precisazione e un consiglio.

Precisazione, è opportuno chiudere le istanza aperte; quindi:

...
...
...
     MsgBox "File spostati da: " & Pth & " a: " & DPth
Set Fd = Nothing                      '  Modifica
Set FSO = Nothing                     '  Modifica
Application.ScreenUpdating = True     '  Modifica
    End
10:
    MsgBox "La Procedura non è andata a buon fine."
Set Fd = Nothing                      
Set FSO = Nothing                     
Application.ScreenUpdating = True     
End Sub

 

Consiglio, sarebbe utile aggiungere in controllo:

...
...
...
Cells(1, 1).Value = Cartella

If Cartella = "" Or Cartella = Origine Then
MsgBox "È necessario scegliere una Cartella di destinazione valida."
Set Fd = Nothing
Application.ScreenUpdating = True
End
End If
...
...
...

Questo controllo evita che in fase di selezione della Cartella di destinazione si prema il Pulsante "Annulla" oppure non venga selezionata alcuna Cartella.

 

Giuseppe

[Autore]

Articoli