Move files from Subfolder to Parent Folder

[SjofaaSj]

@SNB & COW18

Skuzeer dat ik er nog niet eerder op gereageerd heb, maar hectische corona-week op 't werk
Ik moet de uitbreidingen nog verder bekijken, maar ben jullie beiden al zeer erkentelijk voor de geboden hulp!

 

[SjofaaSj]

[ het weer is wat slechter dus kunnen we terug achter de PC kruipen ipv in de tuin te werken ]

SNB nog eens bedankt voor de hulp van enkele weken terug.
Alleen loopt de procedure nog steeds vast als een bestand al bestaat in de parent folder.


Ik vermoed dat hernoeming van dat bestand met een volgnummer wellicht te complex zal zijn,
maar ik zou al erg blij mocht de procedure er niet op vastlopen en de rest afwerken,
evenwel dan zonder die subfolder (met het 'dubbele' bestand erin) te verwijderen maar door achteraf een melding te geven welke subfolder problemen gaf.

Ipv een hardcoded vaste startfolder heb ik een functie gebruikt ; kan ik die laten starten vanaf een vaste locatie?
Nu start die steeds in documenten en dat is niet echt praktisch.

Ik heb nu deze code

Sub M_snb()
  Dim myPath As String
  Dim myFile As String
  Dim cnt As Integer
'PRm
    Set fs = CreateObject("scripting.filesystemobject")
    myPath = SelectFolder()
    'M_snb_000 "G:\OF"
    'M_snb_000 "G:\OF", True
    
    M_snb_000 myPath
    M_snb_000 myPath, True
'RUN
  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

Function SelectFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    SelectFolder = sItem
    Set fldr = Nothing
End Function

 

[snb]

Zo dan ?

Dim fs
Sub M_snb()
    Set fs = CreateObject("scripting.filesystemobject")
    With Application.FileDialog(4)
       .InitialFileName = Application.DefaultFilePath
       If .Show Then myPath = .SelectedItems(1)
     End With
    
    M_snb_000 myPath
    M_snb_000 myPath, True
  
  sn = Split(Mid(c02, 2), vbLf)
  For Each it In sn
    For Each it1 In fs.GetFolder(it).Files
      If Dir(it1.ParentFolder.ParentFolder & "\" & it1.Name) <> "" Then c03 = "_Q_"
      it1.Move it1.ParentFolder.ParentFolder & "\" & c03 & it1.Name
      c03 = ""
    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