Gegevens uit 5 mappen ophalen en verzamelen op één blad

[vhenk]

Goedendag,

Op het form eindelijk gisteren het script gevonden om mee te werken, ivm dat ik een script had wat waar ik het niet kreeg aangepast om te zorgen dat hij niet vraag om een locatie waar hij de gegevens dient op te halen, maar dat dit al in het script staat zoals nu in onderstaande.
Nu de vraag.
Ik heb 5 mappen waar ik gegevens uit wil halen, nu met één map gaat het nog maar ik wil de gegevens uit die mappen verzammelen op één worksheet.
Ik heb al geprobeerd om meerdere locatie`s erbij te zetten maar dan geef hij een foutmelding.

Sub tst()
  c0 = "Bestandsnamen"
  With CreateObject("scripting.filesystemobject").GetFolder("C:\# P h o t o s h o p   B a t c h\F o t o B k")
    For Each fl In .Files
        If Right(fl.Name, 4) = ".jpg" Then c0 = c0 & fl.Name & "|"
    Next
    For Each sfl In .subfolders
      For Each fl In sfl.Files
        If Right(fl.Name, 4) = ".jpg" Then c0 = c0 & sfl.Name & "/" & fl.Name & "|"
      Next
    Next
    [A:A].ClearContents
    [A1].Resize(UBound(Split(c0, "|"))) = WorksheetFunction.Transpose(Split(c0, "|"))
  End With
End Sub

Is dit mogelijk , en weet iemand hier de oplossing voor
Groet Henk

Ben zelf nog aan het knutselen geweest en kwam uit op het volgende ( helaas wel erg lang )
maar werkt wel. Nu is het zo dat een map wel eens leeg is maar dan gaat het script over zijn nek en krijg ik een foutmelding.
Kan iemand mij hier helpen.
vraag in het kort:
- Hoe te doen als de map leeg is
- Kan het script korter

Groet Henk

Sub tst()
  c0 = ""
  With CreateObject("scripting.filesystemobject").GetFolder("C:\# P h o t o s h o p   B a t c h\3 - M a s t e r")
    For Each fl In .Files
        If Right(fl.Name, 4) = ".psd" Then c0 = c0 & fl.Name & "|"
    Next
    For Each sfl In .subfolders
      For Each fl In sfl.Files
        If Right(fl.Name, 4) = ".psd" Then c0 = c0 & sfl.Name & "/" & fl.Name & "|"
      Next
    Next
    [A:A].ClearContents
    [A2].Resize(UBound(Split(c0, "|"))) = WorksheetFunction.Transpose(Split(c0, "|"))
    
Cells.Replace What:=".psd", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

  End With
   
   c0 = ""
  With CreateObject("scripting.filesystemobject").GetFolder("C:\# P h o t o s h o p   B a t c h\JPG M a s t er")
    For Each fl In .Files
        If Right(fl.Name, 4) = ".jpg" Then c0 = c0 & fl.Name & "|"
    Next
    For Each sfl In .subfolders
      For Each fl In sfl.Files
        If Right(fl.Name, 4) = ".jpg" Then c0 = c0 & sfl.Name & "/" & fl.Name & "|"
      Next
    Next
    [b:b].ClearContents
    [b2].Resize(UBound(Split(c0, "|"))) = WorksheetFunction.Transpose(Split(c0, "|"))
    
Cells.Replace What:=".jpg", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

  End With
   c0 = ""
  With CreateObject("scripting.filesystemobject").GetFolder("C:\# P h o t o s h o p   B a t c h\F o t o B k")
    For Each fl In .Files
        If Right(fl.Name, 4) = ".jpg" Then c0 = c0 & fl.Name & "|"
    Next
    For Each sfl In .subfolders
      For Each fl In sfl.Files
        If Right(fl.Name, 4) = ".jpg" Then c0 = c0 & sfl.Name & "/" & fl.Name & "|"
      Next
    Next
    [c:c].ClearContents
    [c2].Resize(UBound(Split(c0, "|"))) = WorksheetFunction.Transpose(Split(c0, "|"))
    
Cells.Replace What:=".jpg", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

  End With
   c0 = ""
  With CreateObject("scripting.filesystemobject").GetFolder("C:\# P h o t o s h o p   B a t c h\W e b P i c")
    For Each fl In .Files
        If Right(fl.Name, 4) = ".jpg" Then c0 = c0 & fl.Name & "|"
    Next
    For Each sfl In .subfolders
      For Each fl In sfl.Files
        If Right(fl.Name, 4) = ".jpg" Then c0 = c0 & sfl.Name & "/" & fl.Name & "|"
      Next
    Next
    [d:d].ClearContents
    [d2].Resize(UBound(Split(c0, "|"))) = WorksheetFunction.Transpose(Split(c0, "|"))
    
Cells.Replace What:=".jpg", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

  End With
  c0 = ""
  With CreateObject("scripting.filesystemobject").GetFolder("C:\# P h o t o s h o p   B a t c h\W e b T N")
    For Each fl In .Files
        If Right(fl.Name, 4) = ".jpg" Then c0 = c0 & fl.Name & "|"
    Next
    For Each sfl In .subfolders
      For Each fl In sfl.Files
        If Right(fl.Name, 4) = ".jpg" Then c0 = c0 & sfl.Name & "/" & fl.Name & "|"
      Next
    Next
    [e:e].ClearContents
    [e2].Resize(UBound(Split(c0, "|"))) = WorksheetFunction.Transpose(Split(c0, "|"))
    
Cells.Replace What:=".jpg", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

  End With
   c0 = ""
  With CreateObject("scripting.filesystemobject").GetFolder("C:\# P h o t o s h o p   B a t c h\2 - T o D o")
    For Each fl In .Files
        If Right(fl.Name, 4) = ".jpg" Then c0 = c0 & fl.Name & "|"
    Next
    For Each sfl In .subfolders
      For Each fl In sfl.Files
        If Right(fl.Name, 4) = ".jpg" Then c0 = c0 & sfl.Name & "/" & fl.Name & "|"
      Next
    Next
    [f:f].ClearContents
    [f2].Resize(UBound(Split(c0, "|"))) = WorksheetFunction.Transpose(Split(c0, "|"))
    
Cells.Replace What:=".jpg", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

  End With
End Sub

 

[snb]

Sub bestanden()
  c0 = ""
  With CreateObject("scripting.filesystemobject")
     for j = 1 to 5
       .GetFolder([COLOR="Teal"]"C:\"[/COLOR] & choose(j,[COLOR="teal"]"map1","map2","map3","map4","map5"[/COLOR]))
       For Each fl In .Files
         If Right(fl.Name, 4) = ".jpg" Then c0 = c0 & .Name & "\" & fl.Name & "|"
       Next
    Next
    [A:A].ClearContents
    [A1].Resize(UBound(Split(c0, "|"))) = WorksheetFunction.Transpose(Split(c0, "|"))
  End With
End Sub

Pas de blauwgroene tekst aan aan jouw situatie.

 

[vhenk]

korte script helaas toch een foutmelding

Bedankt voor de zeer korte scrip.
Enkel er komen zoals in mijn voorbeeld ook .PSD bestanden voor, en daar struikeld hij nu waarschijnlijk over.
Ik krijg de foutmelding op

       For Each fl In .Files

Is dit werkelijk de fout ! of zit ik op het verkeerde spoor.
Eigenlijk wil eigenlijk ook de mapnaam boven de verschillende rijen, is dit ook mogelijk of vraag ik nu het onmogelijke.
Alvast weer bedankt

Henk

Sub bestanden()
  c0 = ""
  With CreateObject("scripting.filesystemobject")
     For j = 1 To 6
       .GetFolder ("C:\" & Choose(j, "# P h o t o s h o p   B a t c h\3 - M a s t e r", "# P h o t o s h o p   B a t c h\Groep foto`s JPG", "# P h o t o s h o p   B a t c h\F o t o B k", "# P h o t o s h o p   B a t c h\W e b P i c", "# P h o t o s h o p   B a t c h\W e b T N", "# P h o t o s h o p   B a t c h\W e b T N"))
       For Each fl In .Files
         If Right(fl.Name, 4) = ".jpg" Then c0 = c0 & .Name & "\" & fl.Name & "|"
       Next
    Next
    [A:A].ClearContents
    [A1].Resize(UBound(Split(c0, "|"))) = WorksheetFunction.Transpose(Split(c0, "|"))
  End With
End Sub

 

[snb]

Ik vraag me af of dit wel geldige mapnamen zijn met een # in de naam.
De fout zit in het niet-bestaan van de gespecificeerde mappen.

die psd bestanden lossen we op met

Sub bestanden()
  c0 = ""
  With CreateObject("scripting.filesystemobject")
     for j = 1 to 5
       .GetFolder("C:\" & choose(j,"map1","map2","map3","map4","map5"))
       For Each fl In .Files
         If [COLOR="Teal"]instr(".jpg.psd",Right(fl.Name, 4))>0[/COLOR] c0 = c0 & .Name & "\" & fl.Name & "|"
       Next
    Next
    [A:A].ClearContents
    [A1].Resize(UBound(Split(c0, "|"))) = WorksheetFunction.Transpose(Split(c0, "|"))
  End With
End Sub

Zolang de code niet loopt maken we ons nog niet druk om de vormgeving van de uitvoer: alles op zijn tijd.

 

[vhenk]

Als ik deze code toepast dan geef hij een fout aan heel de regel in het rood

 If instr(".jpg.psd",Right(fl.Name, 4))>0 c0 = c0 & .Name & "\" & fl.Name & "|"

Ik heb al geprobeerd wat dingen te veranderen maar helaas zonder resultaat.
Ik hoop dat je me kunt helpen.

Dat er # in de naam staat is ook in het script opgenomen in photoshop, kan ik niet veranderen.
In mijn lange versie pakt hij de directorie wel

Henk

 

[snb]

Sub bestanden()
  sq = range("A1:E200")
  With CreateObject("scripting.filesystemobject")
     For j = 1 To 5
       jj=2
       With .GetFolder ("C:\# P h o t o s h o p   B a t c h\" & Choose(j, "3 - M a s t e r", "Groep foto`s JPG", "F o t o B k", "W e b P i c", "W e b T N"))
         sq(1,j)=.path
         For Each fl In .Files
           If instr(".jpg.psd",Right(fl.Name, 4))>0 Then
              sq(jj,j)= fl.Name
              jj=jj+1
           end if
         Next
       End With
    Next
    with [A1:A200]
      .ClearContents
      .value=sq
    end with
  End With
End Sub

 

[vhenk]

Nog niet opgelost

De code werkt niet , krijg nog steeds een foutmelding op dezelfde regel.
Ik heb de mappen aangepast om te kijken of het aan de # lag .

Hij geef de fout melding op de volgende regel

       For Each fl In .Files

Sub bestanden()
  c0 = ""
  With CreateObject("scripting.filesystemobject")
     For j = 1 To 5
       .GetFolder ("C:\Test\" & Choose(j, "Test", "Test", "Test", "Test", "Test"))
       For Each fl In .Files
         If InStr(".jpg.psd", Right(fl.Name, 4)) > 0 Then c0 = c0 & .Name & "\" & fl.Name & "|"
       Next
    Next
    [A:A].ClearContents
    [A1].Resize(UBound(Split(c0, "|"))) = WorksheetFunction.Transpose(Split(c0, "|"))
  End With
End Sub

Ik hoop dat je me kunt helpen

Alvast bedankt
Henk

ps,

Ik krijg deverschillende mappen wel te zien in verschillende kolomen ?
Die heb ik nodig om verticaal te zoeken in een ander bestand om te kijken of er een foto aan wezig is in die bepaalde map.
( misschien vor later om dit via VBA te doen

 

[snb]

Vorige suggestie aangepast

 

[vhenk]

Weer een stap verder

Ik heb de lijst nu gemaakt Top en dat met zo`n kort code met vergeleken wat ik zelf had complimenten.

In de lijst krijg je nu te zien :

3 - M a s t e r\ 1161300.psd
JPG M a s t er\ 1161300 .jpg
F o t o B k\ 1161300.jpg
W e b P i c\ 1161300.jpg
W e b T N\ 1161300.jpg
2 - T o D o\ 2275036.jpg

Nu is de bedoeling eigenlijk , en misschien ben ik niet duidelijk geweest dat ik de verschillende mappen in kolomen krijg naast elkaar

Met deze lijst heb ik een overzicht welke foto`s ik in mijn bestand heb staan ( foto`s zijn verschllende maten vandaar dat ik 5 dezelfde namen krijg ) de to do spreek voor zich

Ik heb een bestand C:\# P h o t o s h o p B a t c h\artikelbestand.xls waar ik mee ga vergelijken welke foto ik wel heb en niet heb. In kolom 1 heb ik het gehele artikelbestand staan en daar zou ik eigenlijk met een JA er achter willen laten zien of er een foto is ja of " " en dit dan per kolom één van bovengenoemde bestanden

Is dit mogelijk?

Ik hoor graag of dit mogelijk is

 

[snb]

eervorige suggestie aangepast

 

[vhenk]

Bedankt voor de code.
Helaas geef hij bij mij een foutmelding op de volgende regel.

              sq(jj, j) = fl.Name

Zo de code zoals je mij hem heb gegeven :

Sub bestanden()
  sq = Range("A1:E200")
  With CreateObject("scripting.filesystemobject")
     For j = 1 To 5
       jj = 2
       With .GetFolder("C:\# P h o t o s h o p   B a t c h\" & Choose(j, "3 - M a s t e r", "JPG M a s t er", "F o t o B k", "W e b P i c", "W e b T N"))
         sq(1, j) = .Path
         For Each fl In .Files
           If InStr(".jpg.psd", Right(fl.Name, 4)) > 0 Then
              sq(jj, j) = fl.Name
              jj = jj + 1
           End If
         Next
       End With
    Next
    With [A1:A200]
      .ClearContents
      .Value = sq
    End With
  End With
End Sub

Groet Henk

 

[snb]

Zoals je al gezien had is 200 de bovengrens van matrix sq.
Als het om meer bestanden gaat moet je die bovengrens vergroten.

 

[vhenk]

Ok code werkt voor een deel.

Ik krijg enkel de lijst van de .psd te zien en niet van de ander mappen.

Sub bestanden()
  sq = Range("A1:E1500")
  With CreateObject("scripting.filesystemobject")
     For j = 1 To 5
       jj = 2
       With .GetFolder("C:\# P h o t o s h o p   B a t c h\" & Choose(j, "3 - M a s t e r", "JPG M a s t er", "F o t o B k", "W e b P i c", "W e b T N"))
         sq(1, j) = .Path
         For Each fl In .Files
           If InStr(".jpg.psd", Right(fl.Name, 4)) > 0 Then
              sq(jj, j) = fl.Name
              jj = jj + 1
           End If
         Next
       End With
    Next
    With [A1:A1500]
      .ClearContents
      .Value = sq
    End With
  End With
End Sub

Ik heb al zitten kijken of ik het kan vinden wat er verkeerd in staat maar dat gaat me net boven me pet.
Ik leer wel veel hiervan, maar wel even puzzelen.
Ik hoop dat je me met mijn vraag kan helpen.

In de bijlage vind je ene overzicht waar ik eigenlijk wil met vertikaal zoeken of er een foto in de mappen staat ja of nee.
Misschien is dit gelijk mogelijk of dat dit een volgende stap is en eerst kijken of de code het doet.

een dankbare Henk

 

[snb]

Ik weet nog wel iemand die deze zakelijke toepassing voor jullie op zakelijke basis wil maken.

 

[vhenk]

Ik begrijp je..

De code die ik hier eerder heb gebruikt deed het ook al.

Sub tst()
  c0 = ""
  With CreateObject("scripting.filesystemobject").GetFolder("C:\# P h o t o s h o p   B a t c h\3 - M a s t e r")
    For Each fl In .Files
        If Right(fl.Name, 4) = ".psd" Then c0 = c0 & fl.Name & "|"
    Next
    For Each sfl In .subfolders
      For Each fl In sfl.Files
        If Right(fl.Name, 4) = ".psd" Then c0 = c0 & sfl.Name & "/" & fl.Name & "|"
      Next
    Next
    [A:A].ClearContents
    [A2].Resize(UBound(Split(c0, "|"))) = WorksheetFunction.Transpose(Split(c0, "|"))
    
Cells.Replace What:=".psd", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

  End With
   
   c0 = ""
  With CreateObject("scripting.filesystemobject").GetFolder("C:\# P h o t o s h o p   B a t c h\JPG M a s t er")
    For Each fl In .Files
        If Right(fl.Name, 4) = ".jpg" Then c0 = c0 & fl.Name & "|"
    Next
    For Each sfl In .subfolders
      For Each fl In sfl.Files
        If Right(fl.Name, 4) = ".jpg" Then c0 = c0 & sfl.Name & "/" & fl.Name & "|"
      Next
    Next
    [b:b].ClearContents
    [b2].Resize(UBound(Split(c0, "|"))) = WorksheetFunction.Transpose(Split(c0, "|"))
    
Cells.Replace What:=".jpg", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

  End With
   c0 = ""
  With CreateObject("scripting.filesystemobject").GetFolder("C:\# P h o t o s h o p   B a t c h\F o t o B k")
    For Each fl In .Files
        If Right(fl.Name, 4) = ".jpg" Then c0 = c0 & fl.Name & "|"
    Next
    For Each sfl In .subfolders
      For Each fl In sfl.Files
        If Right(fl.Name, 4) = ".jpg" Then c0 = c0 & sfl.Name & "/" & fl.Name & "|"
      Next
    Next
    [c:c].ClearContents
    [c2].Resize(UBound(Split(c0, "|"))) = WorksheetFunction.Transpose(Split(c0, "|"))
    
Cells.Replace What:=".jpg", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

  End With
   c0 = ""
  With CreateObject("scripting.filesystemobject").GetFolder("C:\# P h o t o s h o p   B a t c h\W e b P i c")
    For Each fl In .Files
        If Right(fl.Name, 4) = ".jpg" Then c0 = c0 & fl.Name & "|"
    Next
    For Each sfl In .subfolders
      For Each fl In sfl.Files
        If Right(fl.Name, 4) = ".jpg" Then c0 = c0 & sfl.Name & "/" & fl.Name & "|"
      Next
    Next
    [d:d].ClearContents
    [d2].Resize(UBound(Split(c0, "|"))) = WorksheetFunction.Transpose(Split(c0, "|"))
    
Cells.Replace What:=".jpg", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

  End With
  c0 = ""
  With CreateObject("scripting.filesystemobject").GetFolder("C:\# P h o t o s h o p   B a t c h\W e b T N")
    For Each fl In .Files
        If Right(fl.Name, 4) = ".jpg" Then c0 = c0 & fl.Name & "|"
    Next
    For Each sfl In .subfolders
      For Each fl In sfl.Files
        If Right(fl.Name, 4) = ".jpg" Then c0 = c0 & sfl.Name & "/" & fl.Name & "|"
      Next
    Next
    [e:e].ClearContents
    [e2].Resize(UBound(Split(c0, "|"))) = WorksheetFunction.Transpose(Split(c0, "|"))
    
Cells.Replace What:=".jpg", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

  End With
   c0 = ""
  With CreateObject("scripting.filesystemobject").GetFolder("C:\# P h o t o s h o p   B a t c h\2 - T o D o")
    For Each fl In .Files
        If Right(fl.Name, 4) = ".jpg" Then c0 = c0 & fl.Name & "|"
    Next
    For Each sfl In .subfolders
      For Each fl In sfl.Files
        If Right(fl.Name, 4) = ".jpg" Then c0 = c0 & sfl.Name & "/" & fl.Name & "|"
      Next
    Next
    [f:f].ClearContents
    [f2].Resize(UBound(Split(c0, "|"))) = WorksheetFunction.Transpose(Split(c0, "|"))
    
Cells.Replace What:=".jpg", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

  End With
End Sub

Hij is alleen een stuk langer .
Via verticaal zoeken exporteerde ik het naar mijn werkblad.
Automatiche opmaak erover heen en allemaal in een script gezet dat het automatisch gebeurd en het werk goed,.

Als ik hier naar jou scripts kijk kan het korter in de scripts en dat trek me aan.
Niet dat ik helpmij gebruik om een programma te schrijven die is al klaar maar het script kan elke keer beter en daar leer ik weer van.
Als het zo over komt is zeker niet de bedoeling geweest .
Stel ik te veel vragen?
Ik hoop toch dat jullie mij verder willen helpen om VBA beter te begrijpen.

Groet Henk

 

[vhenk]

Jammer

Ik wilde graag verder komen in VBA