• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

mappen maken

Status
Niet open voor verdere reacties.
M

Mde

Gebruiker
Lid geworden
17 jun 2015
Berichten
352
Hoi,

In deze post http://www.helpmij.nl/forum/showthread.php/827795-Automatisch-mappen-aanmaken-en-bestanden-naar-verplaatsen vond ik een code om mappen aan te maken.
Dit werkt op zich alleen wil ik niet de hele naam van het bestand maar alleen de auteur.


De bestandsnaam ziet er nu asl volgt uit:
Aalbers, Han - De liefde.epub
Alcott, Louisa - onder moeder
Alcott, Louisa - op eigen

Nu wil ik graag dat alles van dezelfde schrijver in 1 map komt.
Het is een lijst met ong. 3000 titels :eek:

Kan iemand me helpen?

Code: 
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 epub bestanden staan
    dFolder = VraagMap

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

    'Verdeel de epub bestanden over mappen met dezelfde naam als het epub 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 epub bestand naar zijn folder
        FileCopy dFolder & "\" & fName(i) & ".epub", dFolder & "\" & fName(i) & "\" & fName(i) & ".epub"

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

    Next
End Sub
 
Begrijp ik goed dat je een excellijst met titels hebt die correspondeert met (.epub-)bestanden op je harde schijf die je per auteur wilt kopieren naar een map?
Plaats even een representatief voorbeeldbestand graag.
 
Nee ik heb geen lijst in Excel.
Deze code haalt in de folder de naam op met betreffende extensie en maakt daar een map van en plaatst dan betreffende file in de map.
 
Maak er eens dit van:
Code: 
Sub VerdeelBestanden()
    Dim dFolder As String
    Dim dFile As String
    Dim fld() As String
    Dim Map As String
    
    [COLOR="#008000"]'Vraag de naam van de folder waar de epub bestanden staan[/COLOR]
    dFolder = VraagMap

    dFile = Dir(dFolder & "\*.epub")
    Do While dFile <> ""
        fld = Split(dFile, " - ")
        Map = dFolder & "\" & fld(0)
        On Error Resume Next
        MkDir Map
        On Error GoTo 0
        FileCopy dFolder & "\" & dFile, Map & "\" & dFile
       [COLOR="#008000"] 'Kill dFolder & "\" & dFile[/COLOR]
        dFile = Dir()
    Loop
End Sub

Ik ben er vanuit gegaan dat de naam van het bestand altijd zo is opgebouwd: Auteur - Titel.epub
Om de originele bestanden daadwerkelijk te verwijderen haal je de enkele quote voor de Kill opdracht weg.
 
Laatst bewerkt:
Dank je werkt.
Komt af en toe met fout melding dat die pad niet kan vinden maar dat is niet zo erg, scheelt toch hoop werk
 
Dat zal dan aan de opbouw van de naam liggen. Hij gaat dus uit van: Auteur, spatie, min teken, spatie, Titel.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan