Automatisch mappen aanmaken en bestanden naar verplaatsen.

[r3000]

Ik ben op zoek naar een code of software om van een groep files in een bepaalde folder (in mijn geval pdf bestanden) automatisch mappen aan te laten maken en met dezelfde naam als de (pdf) file waarbij iedere (pdf) file in de specifieke folder wordt geplaatst.

Bijvoorbeeld:

c:\map1\01.pdf
c:\map1\02.pdf
c:\map1\03.pdf

Wordt:
c:\map1\01\01.pdf
c:\map1\02\02.pdf
c:\map1\03\03.pdf

Anybody?

 

[edmoor]

En dat wil je vanuit Excel doen?

 

[r3000]

Ik begrijp dat dat niet handig is vanuit excel. Maar ik ken zelf geen andere mogelijkheid. Ben alleen enigszins bekend met VBA, verder niet.
Dus alle voorstellen zijn zeer welkom!

 

[edmoor]

Ok, dat kan. Kijk naar de volgende functie en sub. Plaats ze in een module.
Die sub laat je dan activeren door een button.

Function VraagMap() As String
    Dim fldr As FileDialog
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Selecteer een map"
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show = -1 Then
            VraagMap = .SelectedItems(1)
        End If
    End With
    Set fldr = Nothing
End Function


Sub VerdeelBestanden()
    Dim dFolder As String
    Dim dFile As String
    Dim fName() As String
    Dim i As Integer
    
    'Vraag de naam van de folder waar de PDF bestanden staan
    dFolder = VraagMap

    'Verzamel de PDF bestanden en sla alleen de namen zonder de extensie (.pdf) op
    dFile = Dir(dFolder & "\*.pdf")
    Do While dFile <> ""
        ReDim Preserve fName(i) As String
        fName(i) = Left(dFile, Len(dFile) - 4)
        i = i + 1
        dFile = Dir()
    Loop

    'Verdeel de PDF bestanden over mappen met dezelfde naam als het PDF bestand
    For i = 0 To UBound(fName)

        'Maak de map als deze niet bestaat
        If Dir(dFolder & "\" & fName(i), vbDirectory) = "" Then
            MkDir dFolder & "\" & fName(i)
        End If
        
        'Kopieer het PDF bestand naar zijn folder
        FileCopy dFolder & "\" & fName(i) & ".pdf", dFolder & "\" & fName(i) & "\" & fName(i) & ".pdf"

        'Verwijder het originele PDF bestand
        Kill dFolder & "\" & fName(i) & ".pdf"

    Next
End Sub

Er zitten wat leuke dingen in om te werken met files en folders, een array, een functie, 2 soorten looping en file system opdrachten. Het kan allemaal mooier en korter maar ik heb het met opzet makkelijk leesbaar gehouden.

 

[r3000]

Oké, top oplossing! Precies wat ik bedoel.
Nu de vervolgvraag, wellicht dat je me daar ook mee kunt helpen.

In excel heb ik de padnamen van alle bestandsnamen staan.
Per bestandsnaam heb ik er achter staan hoe vaak ik een kopie van dit bestand nodig heb.
Zie bijgaand voorbeeld: Bekijk bijlage Voorbeeld 2.xlsx

Nu zou ik graag willen dat elk bestand automatisch het aantal keer wordt gekopieerd in de betreffende folder.

Dus:
C:\MRB 001\MRB 001.pdf

Wordt:
C:\MRB 001\MRB 001.pdf
C:\MRB 001\MRB 001 - Copy.pdf
C:\MRB 001\MRB 001 - Copy (2).pdf
C:\MRB 001\MRB 001 - Copy (3).pdf
C:\MRB 001\MRB 001 - Copy (4).pdf
C:\MRB 001\MRB 001 - Copy (5).pdf
C:\MRB 001\MRB 001 - Copy (6).pdf
etc... Al naar gelang het aantal aangegeven.

De oplossing is zéér welkom!!

Groeten,
Remco.

 

[edmoor]

Dat is eenvoudig te programmeren, maar wat is het doel van zoveel kopieën?

 

[r3000]

Elke PDF file is een rapport voor meerdere stukken equipement.

Dus MRB 001 verwijst naar bijvoorbeeld 15 verschillende stuks equipement, MRB 002 verwijst naar weer een ander aantal, etc.

Voor elk stuk equipement wil ik een apart rapport opslaan.
Daarom heb ik het aantal maal dat een stuk equipement voor komt in een rapport, een kopie nodig van het betreffende rapport.

Na deze actie heb ik al een stuk programma dat elke file hernoemt naar het betreffende stuk equipement.

 

[r3000]

Dat programma heb ik via deze vraag verkregen.

http://www.helpmij.nl/forum/showthread.php/827395-bestandsnaam-hernoemen-vanuit-excellijst

 

[edmoor]

Ok, je vraag is dus opgelost?

 

[r3000]

Mijn aanvullende vraag aan jou, de kopieer" vraag, is hiermee nog niet opgelost.
Het daarna hernoemen van de files wel.

 

[edmoor]

Ok, daarvoor heb ik het volgende voor je bedacht, waarbij je de Sub CopyPDF achter een knop kunt hangen:

Sub CopyPDF()
    Dim StartRow As Integer
    Dim EndRow As Integer
    Dim BstPad As String
    Dim BstNam As String
    Dim BstExt As String
    Dim BstFul As String
    Dim i As Integer
    Dim j As Integer
    
    With ActiveSheet
        StartRow = .UsedRange.Row + 1
        EndRow = .Range("A" & Rows.Count).End(xlUp).Row
    End With
    
    For i = StartRow To EndRow
        BstFul = Range("A" & i).Value
        BstPad = GetSection("PATH", BstFul)
        BstNam = GetSection("FILE", BstFul)
        BstExt = GetSection("EXTN", BstFul)
        For j = 1 To Range("B" & i).Value
            FileCopy Range("A" & i).Value, BstPad & BstNam & " - Copy(" & j & ")." & BstExt
        Next j
    Next i

End Sub

Function GetSection(ByVal sSection As String, sFullpath As String) As String
    Dim AllSect() As String
    Dim i As Integer
    
    AllSect = Split(sFullpath, "\")
    Select Case sSection
        Case "PATH"
            For i = 0 To UBound(AllSect) - 1
                GetSection = GetSection & AllSect(i) & "\"
            Next i
        Case "FILE"
            i = InStr(AllSect(UBound(AllSect)), ".")
            GetSection = Left(AllSect(UBound(AllSect)), i - 1)
        Case "EXTN"
            i = InStr(AllSect(UBound(AllSect)), ".")
            GetSection = Mid(AllSect(UBound(AllSect)), i + 1)
    End Select
End Function

 

[r3000]

Ik ben helemaal gelukkig!

Enige is dat ik

For j = 1

heb aangepast in

For j = 2

.

Anders krijg ik 1 kopie teveel.

Super bedankt! :thumb:

 

[edmoor]

Ok dan en graag gedaan