Move files from Subfolder to Parent Folder

[SjofaaSj]

Ik krijg wekelijks files aangeleverd die in een boomstructuur staan.
Een map (niveau 0) bevat tientallen folders (niveau 1) die elk op hun beurt ook weer 2 à 3 subfolders (niveau 2) bevatten.
En telkens moet ik alle files slepen naar de bovenliggende folder om dan de subfolder te wissen.
Is zoiets te automatiseren via VBA?

De idee zou zijn om een popup te krijgen om de hoogste parent folder te kiezen (niveau 0)
Die dan alle files uit niveau 2 verplaatst naar niveau 1 en de subfolder niveau 2 dan verwijdert.

ik heb al enkele mogelijkheden gevonden, maar krijg het niet aan de praat
https://www.mrexcel.com/board/threads/vba-move-files-to-subfolders-based-on-filename.1063611/

 

[HSV]

Test dit in een testmap.
De hoofdmapnaam is Nieveau0 die zich in C:\Temp bevindt.

Sub hsv()
Dim oFolder, oSubfolder, oFile
 With CreateObject("Scripting.FileSystemObject")
    For Each oFolder In .GetFolder("C:\Temp\niveau0").subfolders
          For Each oSubfolder In oFolder.subfolders
             For Each oFile In oSubfolder.Files
               .movefile oFile, oFolder & "\"
             Next oFile
          oSubfolder.Delete
       Next oSubfolder
    Next oFolder
  End With
End Sub

 

[SjofaaSj]

Dag Harry

Er gebeurt eigenlijk... niks.

Ik heb een map op m'n bureaublad gezet, genaamd TEST
Daarin zitten 3 subfolders met in elk van hen een aantal files.

dus ik heb deze code

Sub hsv()
 Dim oFolder, oSubfolder, oFile
 
 With CreateObject("Scripting.FileSystemObject")
    For Each oFolder In .GetFolder("D:\XXX\Bureaublad\TEST").SubFolders
          For Each oSubfolder In oFolder.SubFolders
             For Each oFile In oSubfolder.Files
               .MoveFile oFile, oFolder & "\"
             Next oFile
          oSubfolder.Delete
       Next oSubfolder
    Next oFolder
  End With
End Sub

De procedure gaat nooit dieper dan deze lijn "For Each oSubfolder In oFolder.SubFolders"

 

[HSV]

Verwijder die backslash eens achter TEST.

Je hebt het al aangepast zie ik.
Normaal heet het bureaublad → desktop.

 

[SjofaaSj]

ik heb 't pad rechtstreeks uit m'n verkenner gekopieerd (heb een NL versie)
en met of zonder slash op 't einde maakt geen verschil

hij gaat 3 keer door de procedure, dus ziet hij die 3 subfolders wel,
maar hij gaat er gewoon niet in

 

[HSV]

Bij mij staat in de verkenner ook Bureaublad, maar het is toch desktop bij mij in VBA.

De code werkt hier als een tierelier trouwens.

 

[HSV]

Zo zie ik het voor me.

Een hoofdmap genaamd Test op het bureaublad.
Diverse mappen in de hoofdmap.
Diverse mappen in die mappen.
Daarin de bestanden.

Laat maar weten of dat correct is.

 

[SjofaaSj]

exact zoals je 't zegt, maar in dit voorbeeld slechts één niveau dieper
- 1 hoofdmap (= TEST)
- 3 submappen
- bestanden in elk van de submappen
En ik wil de bestanden die in de submappen staan eerst verplaatsen naar de hoofdmap en nadien de submappen verwijderen




=============
EDIT

ik heb in mijn hoofdmap 'TEST nu eens TWEE submappen gezet: Album1 en Album2
En onder die submappen nog eens 3 subfolders: CD1, CD2 en CD3

en dan lukt het wel perfect!

Maar er zijn niet altijd meerdere submappen dus het zou ook moeten lukken als er slechts één onderliggende folder is.

 

[HSV]

Dan zat ik een niveau te diep.

Sub hsv()
Dim oFolder, oFile, s0 As String
s0 = [COLOR=#3E3E3E]"D:\XXX\Bureaublad\TEST"[/COLOR]
 With CreateObject("Scripting.FileSystemObject")
    For Each oFolder In .GetFolder(s0).subfolders
             For Each oFile In oFolder.Files
               .movefile oFile, s0 & "\"
             Next oFile
       oFolder.Delete
    Next oFolder
  End With
End Sub

 

[SjofaaSj]

OK hiermee kan ik wel m'n plan trekken.
Heel erg bedankt voor je hulp op een zondagnamiddag Hans.

Misschien nog 2 dingen ter verfijning (maar da's eerder Nice-to dan Need-To):

1.
Is er een manier om te bepalen hoe diep de subfolders gaan in de opgegeven hoofdmap? Want dan zou de procedure universeel zijn
Bijvoorbeeld: gesteld dat er een folder is waar de submappen 4 niveau's diep gaan, dan zou ik alles van 4 naar 3 trekken en de overige ongemoeid laten.
Desgevallend kan je dan de procedure herhalen als je van 3 naar 2 wil gaan etc...

2.
Momenteel crasht het als er in de parent folder reeds een bestand staat met die naam.
Kan er dan een suffix (1) aan de naam toegevoegd worden zodat je altijd alle bestanden behoudt?

 

[cow18]

diepste niveau (alle \ worden meegeteld vanaf de root !!)

Sub DiepsteNiveau()
   mypath = "c:\users\eigenaar"                  'in deze directory starten
   mijndir = Filter(Split(CreateObject("WScript.Shell").Exec("cmd /c dir /b /s /ad " & mypath).StdOut.ReadAll, vbCr), mypath, 1)   'alle subdirectories
   niveaus = -1
   For i = 0 To UBound(mijndir)                  'alle subdirectories aflopen
      niv = UBound(Split(mijndir(i), "\"))       'hoeveel "\" zijn er ?
      If niveaus < niv Then niveaus = niv: diepste = mijndir(i)   'meer dan de vorige = nieuwe gegevens opslaan
   Next
   MsgBox "aantal niveaus : " & niveaus & vbLf & "diepste niveau : " & diepste
End Sub

 

[SjofaaSj]

@COW18
ingenious!

Werkt ideaal om te zien hoe diep je moet gaan, maar met de meegegeven subfolder kan ik nog niet echt aan de slag
Want als ik goed kan volgen geef je de allereerste folder terug die zo diep gaat?

Stel dat je 4 niveau's diep gaat, maar er zijn meerdere mappen die 4 diep gaan, dan moeten die allemaal behandeld worden
Hetgeen de procedure van HSV dan zou moeten doen is die 'for each subfolder' zoveel keer moet downdrillen tot hij aan het laagste niveau is
maar dan startend vanuit de oorspronkelijk gekozen map zodat je overal de files uit niveau 4 naar 3 brengt?

Of is dat a bridge too far?

 

[cow18]

als het een brug is, dan een heel kleintje.
Zie bijlage, in D1 zet je het path en je laat de macro lopen.
in mijn geval was die 10 diep (je telt in mijn geval 10 \-tekens vanaf de root, dus inclusief die van het path)

Nu heb ik wat aanpassingen gedaan, zodat mijn macro die van HSV aanroept en dat die met de goeie instellingen verder werkt.
Ben je zover, dan haal je dat rode enkel aanhalingsteken voor hsv weg uit mijn macro (zie hieronder)
Test dit wel eventjes op een ongevaarlijke plaats.

        s0 = Left(s0, Len(s0) - 1)
     [COLOR="#FF0000"] 'hsv[/COLOR]                                        ' roep met bovenstaande s0 nu hsv's macro aan
   Next

 

[HSV]

Geen idee wat er met mijn Getfolder aan de hand is.
Als ik er een harde verwijzing in zet loopt de code door, en met de variabel s0 krijg ik de error:76 "Kan het pad niet vinden".

Wat zie ik over het hoofd.

 For Each oFolder In .GetFolder("c:\users\xxxxx\desktop\niveau\nieuwemap1").subFolders

 For Each oFolder In .GetFolder(s0).subFolders

s0 is identiek aan de harde verwijzing.

 

[cow18]

helemaal boven in de module "Global s0", die hard declareren als string ipv. variant ???

 

[snb]

ten diepste bemoedigend

Met recursie en diverse 'diepste' nivo's:

Dim fs, c01, c02

Sub M_snb()
  Set fs = CreateObject("scripting.filesystemobject")

  M_snb_000 "G:\OF"
  M_snb_000 "G:\OF", True
    
  sn = Split(Mid(c02, 2), vbLf)
  For Each it In sn
    For Each it1 In fs.getfolder(it).Files
      it1.Move it1.ParentFolder.ParentFolder & "\" & it1.Name
    Next
    fs.DeleteFolder it
  Next
End Sub

Sub M_snb_000(c00, Optional b As Boolean)
  If UBound(Split(c00, "\")) > UBound(Split(c01, "\")) Then c01 = c00
  If UBound(Split(c00, "\")) = UBound(Split(c01, "\")) And b Then c02 = c02 & vbLf & c00
    
  For Each it In fs.getfolder(c00).subfolders
    M_snb_000 it, b
  Next
End Sub

 

[cow18]

ik ga het idee achter die recursie mij toch moeten eigen maken, toch simpel en knap.
Heb je basisliteratuur ?

 

[snb]

Ik zag laatst toevallig deze: https://www.snb-vba.eu/VBA_Recursion.html

 

[cow18]

en ik die dacht dat ik je site helemaal gelezen had.
Begrijpend lezen voor dummies in de linkerkantlijn.
Dat wordt iets voor een avond met een glas wijn.

 

[snb]

Soms kan ik het niet laten er wat aan toe te voegen.