Lijst in Excel met de bestanden namen uit een map

Status
Niet open voor verdere reacties.
A

aromijn99

Gebruiker
Lid geworden
9 sep 2013
Berichten
39
Hallo,

Ik ken VBA eigenlijk niet maar ik heb wel een scriptje op internet gevonden en in een makro gezet in Excel waarmee in een lijst met bestandsnamen kan maken in excel. Het werkt uitstekend:

Code: 
Sub overzicht()
  With CreateObject("scripting.filesystemobject").GetFolder("C:\Users\Romijn\Pictures")
  For Each fl In .Files
     If Right(fl.Name, 4) = ".jpg" Then Cells(Rows.Count, 1).End(xlUp).Offset(1) = fl.Name
  Next
  End With
End Sub

Maar ik zou graag meer willen: in een kolom ernaast het pad van de bestandnaam (zonder de bestandsnaam als dat kan).
Ik zou graag daarom ook willen dat hij automatisch submappen ook leest en hiermee de lijst aanvult.
De makro die ik heb neemt geen videobestanden, zoals mp4, mee.

Waar ik naar op zoek ben dus: een makro voor excel waarbij je een map opgeeft (in de makro gewoon zet) bijv C:\Users\Romijn\Pictures en dat dan in kolom A alle bestandnamen komen met extentie en in kolom B het bijhorende pad. zoiets:
DSC_2345.jpg C:\Users\Romijn\Pictures
DSC_2346.jpg C:\Users\Romijn\Pictures
DSC_5346.jpg C:\Users\Romijn\Pictures\vakantie
MOV_2628.mp4 C:\Users\Romijn\Pictures\vakantie\videos

Ik ben al heel lang hierna op zoek maar vanwege mijn gebrek aan kennis hoop ik dat het gewoon simpel kan. Althans voor mij (kopiëren en in Excel macro plakken).

Wie kan/wil mij helpen? Alvast bedankt!

Groetjes Astrid
 
Code: 
sub M_snb()
  sn=split(createobject("wscript.shell").exec("cmd /c Dir C:\Users\Romijn\Pictures\*.* /b/s").stdout.readall,vbcrlf)

  cells(1).resize(ubound(sn)+1)=application.transpose(sn)
end sub
 
Hallo Adre@home en SNB,

Heel erg bedankt alvast.
Jullie hebben beiden heel goed geholpen. Echter mijn oplossing bevindt zich in beiden scrips...

Andre@home: door jou heb ik gevonden bij http://www.mrexcel.com/forum/excel-questions/311086-show-contents-folder.html
dit script:

Code: 
Sub CSVFiles()
Dim strFolder As String, ws As Worksheet, strFile As String, r As Range
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .InitialFileName = Application.DefaultFilePath
    If .Show = -1 Then _
        strFolder = .SelectedItems(1)
End With
If strFolder = "" Then MsgBox "No folder selected! Exiting sub...": Exit Sub
Set ws = Worksheets.Add
ws.Range("A1:B1") = Array("Path", "FileName")
strFile = Dir(strFolder & "\*.csv")            [COLOR="#FF0000"]Dit wijzig ik natuurlijk in *.*[/COLOR]
If strFile <> "" Then
    Do
       Set r = ws.Cells(Rows.Count, "A").End(xlUp).Offset(1)
       r.Value = strFolder: r.Offset(, 1).Value = strFile
       strFile = Dir
    Loop Until strFile = ""
End If
End Sub

Dit is wat ik wilde:
+ punt: kolom met pad en een kolom met bestandsnaam + extensie
- punt: geeft geen resultaten van submappen


SNB: jouw scrip:
+ punt: werk fantastisch voor submappen!
- punt: alleen een lijst met pad met bestandnaam in één (zou ik in Excel misschien kunnen ontrafelen maar liever niet)


Wie kan deze scripts combineren?
Zie er uit als bovenstaand script met de submappen van SNB.

Alvast hartelijk dank voor het meedenken!
 
Laatst bewerkt door een moderator:
Kun je svp VBA code tussen code tags zetten ?

Wat is er moeilijk aan om van ieder item in een lijst van 'fullnames' (pad & bestandsnaam) een lijst met per item de bestandnaam en het pad afzonderlijk te maken ?
 
Laatst bewerkt:
Beste snb,

Wat is er moeilijk aan? uh....niet als je genoeg kennis hebt van VBA. Maar een leek ziet dat toch anders. Vandaar een vraag om een kopieer en plak scriptje.
Als het niet te veel moeite is, please :thumb:

Vriendelijke groet!
 
Maar ja, je moet toch ergens starten ?

Waarom dan niet hiermee ? De snelste manier om van je zelfbenoemde lekenstatus af te komen.
 
Laatst bewerkt:
Om je een beetje op weg te helpen:

Code: 
Sub M_snb()
Dim strFolder As String, strFile As String, ws As Worksheet, sn As Variant
Dim arrPad() As Variant, arrBestand() As Variant, arrTmp As Variant
Dim i As Integer
    
    Application.ScreenUpdating = False
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show = -1 Then _
            strFolder = .SelectedItems(1)
    End With
    If strFolder = "" Then MsgBox "No folder selected! Exiting sub...": Exit Sub
    Set ws = Worksheets.Add
    strFile = strFolder & "\*.*"

    sn = Split(CreateObject("wscript.shell").exec("cmd /c Dir " & strFile & "/b/s").StdOut.ReadAll, vbCrLf)
    ReDim arrPad(UBound(sn) - 1)
    ReDim arrBestand(UBound(sn) - 1)
    For i = LBound(sn) To UBound(sn) - 1
        arrTmp = Split(sn(i), "\")
        arrPad(i) = Left(sn(i), Len(sn(i)) - Len(arrTmp(UBound(arrTmp))))
        arrBestand(i) = arrTmp(UBound(arrTmp))
    Next i
    Cells(1).Resize(UBound(arrPad) + 1) = Application.Transpose(arrPad)
    Cells(2).Resize(UBound(arrPad) + 2) = Application.Transpose(arrBestand)
    Selection.EntireRow.Insert
    ws.Range("A1:B1") = Array("Path", "FileName")
    Application.ScreenUpdating = True

End Sub
Zal vast wel slimmer kunnen, maar dit werkt in ieder geval.
 
Laatst bewerkt:
ik dacht meer aan het gebruik van Dir:

Code: 
for j=0 to ubound(sn)
   sn(j)= dir(sn(j)) & "_" & Replace(sn(j), Dir(sn(j)), ""))
next
 
Beste Octofish,

Een beetje? Een beetje veel!!! Dit is precies wat ik graag wilde. Heeeeeeeel erg bedankt!!!!!!!

Beste Snb,

Ook heel erg bedankt voor het helpen. Ik het het geprobeerd met die for next maar die middelste regel werd steeds rood (en doet het dus niet). Het zal wel weer aan mij liggen. Tot bedankt.
 
En om het feest compleet te maken, nog een versie met één matrix i.p.v. 2. Scheelt weer een stukkie...

Code: 
Sub M_Octa()
Dim strFolder As String, strFile As String, ws As Worksheet, sn As Variant
Dim arrTmp As Variant, Arr As Variant
Dim i As Integer
    
    Application.ScreenUpdating = False
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show = -1 Then _
            strFolder = .SelectedItems(1)
    End With
    If strFolder = "" Then MsgBox "No folder selected! Exiting sub...": Exit Sub
    Set ws = Worksheets.Add
    strFile = strFolder & "\*.*"

    sn = Split(CreateObject("wscript.shell").exec("cmd /c Dir " & strFile & "/b/s").StdOut.ReadAll, vbCrLf)
    ReDim Arr(UBound(sn) - 1, 1)
    For i = LBound(sn) To UBound(sn) - 1
        arrTmp = Split(sn(i), "\")
        Arr(i, 0) = Left(sn(i), Len(sn(i)) - Len(arrTmp(UBound(arrTmp))))
        Arr(i, 1) = arrTmp(UBound(arrTmp))
    Next i
    
    ws.Cells(1, 1).Resize(UBound(Arr), UBound(Application.Transpose(Arr))) = Arr
    Selection.EntireRow.Insert
    ws.Range("A1:B1") = Array("Path", "FileName")
    Application.ScreenUpdating = True

End Sub
 
@Octa

Mijn suggesties zijn ook voor jou bedoeld :)

ipv
Code: 
sn = Split(CreateObject("wscript.shell").exec("cmd /c Dir " & strFile & "/b/s").StdOut.ReadAll, vbCrLf)
    ReDim Arr(UBound(sn) - 1, 1)
    For i = LBound(sn) To UBound(sn) - 1
        arrTmp = Split(sn(i), "\")
        Arr(i, 0) = Left(sn(i), Len(sn(i)) - Len(arrTmp(UBound(arrTmp))))
        Arr(i, 1) = arrTmp(UBound(arrTmp))
    Next i


Code: 
    sn = Split(CreateObject("wscript.shell").exec("cmd /c Dir " & strFile & "/b/s").StdOut.ReadAll, vbCrLf)

    ReDim sp(UBound(sn), 1)
    For j = 0 To UBound(sp)
        sp(j,0)=dir(sn(j))
        sp(j,1)=replace(sn(j),sp(j,0),"")
    Next
 
Ben ik heel benieuwd of dat merkbaar sneller is....
 
Daar test ik nooit op sinds ik mijn Intel 8086 machine vervangen heb.
Split is zeker niet de snelste methode uit de VBA stal.
Maar in ieder geval voor mij merkbaar sneller leesbaar.
 
Laatst bewerkt:
Beste OctaFish, het heeft zo mooi gewerkt....
Ik gebruik de makro M_Octa van 15 oktober 2013:
Code: 
Sub M_Octa()
Dim strFolder As String, strFile As String, ws As Worksheet, sn As Variant
Dim arrTmp As Variant, Arr As Variant
Dim i As Integer
    
    Application.ScreenUpdating = False
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show = -1 Then _
            strFolder = .SelectedItems(1)
    End With
    If strFolder = "" Then MsgBox "No folder selected! Exiting sub...": Exit Sub
    Set ws = Worksheets.Add
    strFile = strFolder & "\*.*"

    sn = Split(CreateObject("wscript.shell").exec("cmd /c Dir " & strFile & "/b/s").StdOut.ReadAll, vbCrLf)
    ReDim Arr(UBound(sn) - 1, 1)
    For i = LBound(sn) To UBound(sn) - 1
        arrTmp = Split(sn(i), "\")
        Arr(i, 0) = Left(sn(i), Len(sn(i)) - Len(arrTmp(UBound(arrTmp))))
        Arr(i, 1) = arrTmp(UBound(arrTmp))
    Next i
    
    ws.Cells(1, 1).Resize(UBound(Arr), UBound(Application.Transpose(Arr))) = Arr
    Selection.EntireRow.Insert
    ws.Range("A1:B1") = Array("Path", "FileName")
    Application.ScreenUpdating = True

End Sub

maar nu krijg ik steeds de melding: onvoldoende geheugen...

Dus ik al mijn programma's uitgezet. En toen deed hij het weer.... met een map met 5 bestanden. De mappen die ik nodig had hebben er meer, 560 bestanden. Dat ging niet. Verdeeld over kleine stukken, nu 164 bestanden...maar nog steeds een foutmelding: onvoldoende geheugen.

De Module stopt bij:
Code: 
ReDim Arr(UBound(sn) - 1, 1)

Heb je enig idee wat ik hier aan moet doen?

Alvast weer bedankt!
 
Ik heb het antwoord al gevonden! De bestanden stonden op mijn GoogleDrive. Kennelijk vindt Excel dat teveel denk werk. Mappen gekopieerd naar mijn computer en toen ging alles wel goed. Tja, van mijn mappenstructuur is dan alleen weinig over, want daar staan ze de eigenlijk niet. Gelukkig dat ik nu de structuur niet nodig had, maar als iemand weet hoe je het wel kunt met bestanden op een Googledrive....ik hou mij aanbevolen.
 
Lijst in Excel met de bestanden namen uit een map van een externe schijf

Hallo,

De macro werkt nog steeds prima, maar nu zou ik toch wel heel graag de bestanden met paden van mijn externe harde schijf willen krijgen in Excel.
Maar nog steeds geen voldoende geheugen. En om nu mijn harde schijf van 1 TB naar mijn harde schijf te kopiëren voor een lijst, dat gaat te ver (lees gaat niet op mijn laptop). En ik neem aan dat als het lukt voor mijn externe harde schijf dit dan ook kan voor mijn Googledrive?
ALS het kan...

Iemand die de macro kan aanpassen?

Alvast bedankt voor het nadenken!

Groetjes, Astrid
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan