Creazione cartella con file

Hai un problema con Excel?

Nuova discussione

Creazione cartella con file
di Luca (utente non iscritto) data: 20/02/2016 19:48:52
Buonasera,
vorrei sapere se è possibile creare delle cartelle copiando files il cui nominativo è stato inserito in una colonna excel, mi spiego meglio.

1)Supponiamo che ho una cartella che si chiama pippo sul mio desktop contenente dei file DWG, circa 200 per essere più precisi
2)Nel mio foglio di lavoro ho una colonna, supponiamo la B, che contiene ad esempio 30 nomi dei file DWG (alcuni di questi nomi potrebbero anche ripetersi in alcuni delle 30 righe)
3)Io avrei bisogno che, magari schiacciando un pulsante, i nomi dei file presenti nella mia colonna siano cercati nella cartella pippo e copiati in una nuova cartella. è sufficiente che, se un faile sia stato inserito in più righe, sia copiato un solo DWG, ma mi occore un messagio di ritorno se questo file non viene trovato.

insomma cerca il nome inserito nella cella in pippo e copialo in una nuova cartella, se non c'è avvisami!

non credo che tutto questo si possa creare con Excel, voi cosa ne pensate??
di patel data: 20/02/2016 20:40:05
certo che si può fare, basta allegare un file di esempio
r
di Luca (utente non iscritto) data: 22/02/2016 10:35:44
Bene, ottime notizie!! grazie!
Ho allegato un file d'esempio, nella colonna N puoi trovare i nomi dei DWG da cercare nella cartella Disegni sul desktop, ed andrebbero copiati in una nuova cartella da posizionare sempre sul desktop

di patel data: 22/02/2016 14:34:41
prova questa

Sub copylistfile()
Dim cell As Range
oldpath = "c:UsersAntonioDesktopdisegni"
newpath = "c:UsersAntonioDesktopdisegni2"
LR = Cells(Rows.Count, "N").End(xlUp).Row
For Each cell In Range("N11:N" & LR)
   fn = Dir(oldpath & cell.Value & ".dwg")
   If fn <> "" Then
     FileCopy oldpath & cell.Value & ".dwg", newpath & cell.Value & ".dwg"
   End If
Next
End Sub

r
di Luca (utente non iscritto) data: 23/02/2016 08:53:00
ho oviamente modificato il "link" con quelli delle cartelle sul mio desktop, ma mi da problemi (debug) su questa riga di codice, quella prima dell'End If ...

FileCopy oldpath & cell.Value & ".dwg", newpath & cell.Value & ".dwg"
di patel data: 23/02/2016 08:56:44
la cartella di destinazione è già stata creata ?
r
di Luca (utente non iscritto) data: 23/02/2016 09:27:38
ops! scusa, pensavo si creasse in automatico ...

Molto bene, ci siamo quasi, ho ancora due piccoli problemini!
1°_ Manca il messaggio nel caso in cui il disegno non viene trovato
2°_ Mi sono accorto che in alcuni casi alcuni disegni potrebbero essere posizionati in alcuni sottocartelle della cartella principale, pensi che questo possa essere risolto?

di patel data: 23/02/2016 12:41:49
prova questa

Dim newpath As String, c As Integer
Sub copylistfile1()
Dim cell As Range
oldpath = "c:UsersAntonioDesktopdisegni"
newpath = "c:UsersAntonioDesktopdisegni2"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set mainFolder = objFSO.GetFolder(oldpath)
LR = Cells(Rows.Count, "N").End(xlUp).Row
For Each cell In Range("N11:N" & LR)
   fn = Dir(oldpath & cell.Value & ".dwg")
   If fn <> "" Then
     FileCopy oldpath & cell.Value & ".dwg", newpath & cell.Value & ".dwg"
   Else
      SubFoldersScan OfFolder:=mainFolder, fname:=cell.Value & ".dwg"
      If c = 0 Then MsgBox cell.Value & " non trovato"
   End If
Next
End Sub

Sub SubFoldersScan(OfFolder As Variant, fname As String) ' ricorsiva
    Dim SubFolder
    c = 0
    For Each SubFolder In OfFolder.subfolders
       StrFile = Dir(SubFolder & "" & fname)
       If StrFile <> "" Then
          FileCopy SubFolder & "" & fname, newpath & fname
          c = c + 1
          Exit For
       End If
       SubFoldersScan OfFolder:=SubFolder, fname:=fname
    Next
End Sub

r
di Luca (utente non iscritto) data: 23/02/2016 16:10:08
sembra non funzionare il messaggio di disegno non trovato, nel senso che anche quando trova il DWG compare il messaggio...
forse sarebbe più comodo colorare la cella di giallo del codice che non trova, in questa maniera abbiamo la possibilità ti tenere traccia di quello che manca anche dopo aver finito la macro ...

di patel data: 23/02/2016 17:07:05
a me funziona, hai lasciato la dichiarazione "Dim newpath As String, c As Integer" prima della sub ?

Dim newpath As String, c As Integer
Sub copylistfile1()
Dim cell As Range
oldpath = "................"
newpath = "............."
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set mainFolder = objFSO.GetFolder(oldpath)
LR = Cells(Rows.Count, "N").End(xlUp).Row
For Each cell In Range("N11:N" & LR)
   fn = Dir(oldpath & cell.Value & ".dwg")
   If fn <> "" Then
     FileCopy oldpath & cell.Value & ".dwg", newpath & cell.Value & ".dwg"
   Else
      SubFoldersScan OfFolder:=mainFolder, fname:=cell.Value & ".dwg"
      If c = 0 Then cell.Interior.ColorIndex = 6
   End If
Next
End Sub

Sub SubFoldersScan(OfFolder As Variant, fname As String) ' ricorsiva
    Dim SubFolder
    c = 0
    For Each SubFolder In OfFolder.subfolders
       StrFile = Dir(SubFolder & "" & fname)
       If StrFile <> "" Then
          FileCopy SubFolder & "" & fname, newpath & fname
          c = c + 1
          Exit For
       End If
       SubFoldersScan OfFolder:=SubFolder, fname:=fname
    Next
End Sub

r
di Luca (utente non iscritto) data: 24/02/2016 11:13:51
ho fatto due prove al volo e sembra funzionare ...
grazie 1000!

Vuoi Approfondire?