Foto's zoeken

BART1988 · 30 mrt 2020

@ Cow18

Moet je bovenstaande code ergens bij in de file gezet worden?

cow18 · 30 mrt 2020

je vraagt ook meer dan wat ik kan antwoorden,
Vooreerst verwacht ik dat met 80.000 subdirectories en een veelvoud aan files, de macro vrij lang (minuten) zal bezig zijn met de 1e 3 regels.
Dat zal je zien aan een venster dat zicht opent, maar waar verder niets gebeurt.
Je zou kunnen denken dat je PC hangt, want je zal hem met niets kunnen stoppen behalve met CTRL-ALT-DEL, dus geduld ... .

Eens die verdwenen is, kan het snel gaan.
Ik vermoed niet dat het fout zal gaan tijdens de uitvoering van de macro, dat zal pas gebeuren als de resultaten weggeschreven worden naar je tabblad.
Ga anders in A1, C1 of D1 van foto staan en klik op CTRL-pijltje naar beneden.
Zo sta je helemaal onderin die kolom.
Staat daar een deftige tekst en niet #NB, dan is het gelukt, anders moet ik eea. aanpassen.
Misschien krijg je al eerder een indicatie, als die msgbox opkomt met het aantal subdirectories en fotos.
Hoeveel wordt er daar gezegd ? Mogelijk gaat het daar al fout als die getallen geen integers zijn (groter dan 32.000).

Dus ik zou zeggen, probeer het een keer en meld je terug.

BART1988 · 23 apr 2020

Dag Cow18

Ik heb een tijdje alles uitvoerig getest.
Conclusie: macro werkt perfect, doet wat hij moet doen.

Alleen je opmerking ivm #NB klopt.
Vanaf rij 12847 in “Foto” en rij 12049 in “Geen Foto” loopt het mis, dan worden de nummers #NB.

Mvg en bedankt alvast!

cow18 · 23 apr 2020

oude topic.
Werkt het naar believen of moet er nog iets veranderen ?

Blijkbaar is het zoals SNB opmerkte, boven de zoveel heb je problemen met de transpose.

BART1988 · 23 apr 2020

Als het kan dit...

Staat daar een deftige tekst en niet #NB, dan is het gelukt, anders moet ik eea. aanpassen.

Gaat over deze code

Code:

Sub MijnFotos()

   mypath = Sheets("foto").Range("M1").Value     'in deze directory en onderliggende zoeken
   mijndir = Filter(Split(CreateObject("WScript.Shell").Exec("cmd /c dir /b /s /ad " & mypath).StdOut.ReadAll, vbCr), mypath, 1) 'alle subdirectories
   mijnfiles = Filter(Split(CreateObject("WScript.Shell").Exec("cmd /c dir " & mypath & "/b /s").StdOut.ReadAll, vbCr), "_A.jpg", 1, vbTextCompare)   'alle "_A.jpg"-bestanden in die subdrectories

   MsgBox "er zijn :" & vbLf & "- " & UBound(mijndir) + 1 & " subdirectories" & vbLf & "- " & UBound(mijnfiles) + 1 & " _A.jpg-bestanden"

   For i = 0 To UBound(mijndir)                  'alle subdirectories aflopen
      If Len(mijndir(i)) > 1 Then                'niet in de root
         flt = Filter(mijnfiles, mijndir(i), 1, vbTextCompare)   'alle bestanden in die subdirectory
         b = False                               'vlaggetje resetten
         If UBound(flt) <> -1 Then               'zitten er bestanden in
            For j = 0 To UBound(flt)             'al die bestanden aflopen
               sp = Split(flt(j), "\")           'splitten op "\"
               b = (sp(UBound(sp) - 1) = Left(sp(UBound(sp)), Len(sp(UBound(sp))) - 6))   'komt het voorlaatste stuk overeen met het eerste deel van het laatste stuk ?
               If b Then Exit For                'indien ja, goed bestand gevonden en klaar
            Next
         End If

         If b Then
            s1 = s1 & "|" & mijndir(i)           'voeg subdirectory toe aan de goeie (enkel laatste stuk)
         Else
            s2 = s2 & "|" & mijndir(i)           'voeg subdirectory toe aan de slechte
         End If
      End If
   Next

   sp1 = Split(Mid(Replace(s1, mypath & "\", ""), 2), "|")   'array met alle subdirectories met fotos (mypath is er uit)
   sp2 = Split(Mid(Replace(s2, mypath & "\", ""), 2), "|")   'array met de andere(mypath is er uit)


   With Sheets("foto").Range("A1")
      kleur = IIf(.Interior.ColorIndex = 19, 20, 19)
      .Resize(10000).ClearContents
      If UBound(sp1) <> -1 Then
         With .Resize(UBound(sp1) + 1)
            .Value = Application.Transpose(sp1)
            .Interior.ColorIndex = kleur
         End With
      End If
   End With

   MsgBox "er waren " & UBound(sp2) + 1 & " slechte subdirectories" & vbLf & Join(sp2)
   With Sheets("geen foto").Range("A1")
      .Resize(10000).ClearContents
      .Interior.ColorIndex = kleur
      If UBound(sp2) <> -1 Then
         With .Resize(UBound(sp2) + 1)
            .Value = Application.Transpose(sp2)
            .Interior.ColorIndex = kleur
         End With
      End If
   End With

   With Sheets("foto").Range("D2")               'voor de volledigheid hier ook even eea wegschrijven
      .Resize(10000, 2).ClearContents
      .Interior.ColorIndex = kleur
      If UBound(mijndir) <> -1 Then
         With .Resize(UBound(mijndir) + 1)
            .Value = Application.Transpose(Split(Replace(Join(mijndir, "|"), mypath & "\", ""), "|"))
            .Interior.ColorIndex = kleur
         End With

         If UBound(mijnfiles) <> -1 Then
            With .Offset(, 1).Resize(UBound(mijnfiles) + 1)
               .Value = Application.Transpose(Split(Replace(Join(mijnfiles, "|"), mypath & "\", ""), "|"))
               .Interior.ColorIndex = kleur
            End With
         End If
      End If
      '.EntireRow.EntireColumn.AutoFit
   End With


End Sub
Sub kleuren()
   For i = 1 To 255
      Cells(i, 1).Interior.ColorIndex = i
   Next

End Sub

Jij hebt in vorige posts ook nog is iets gezet ivm 1 000 000 records, kan hier iets van gebruikt worden?

HSV · 23 apr 2020

@Cow18,

transpose =2^16

BART1988 · 24 apr 2020

Dus het maximum aantal mappen die te doorzoeken zijn zal 65 536 zijn?

snb · 24 apr 2020

Kun je oplossen met een virtuele Listbox of Combobox

BART1988 · 27 apr 2020

@ snb

Kan jij je suggestie toepassen op de code #45 dan aub?
Dit gaat mijn petje te boven.

Alvast dank!

cow18 · 28 apr 2020

ik weet niet meer precies hoe het zat, dus een gok.
Hierbij wordt iedere 1.000(=iMax) records het zaakje weggeschreven, zodat met die transpose zeker geen problemen voordoen.
Belangrijk is dat die Global Dict1,Dict2 bovenin de module staan

Kijk het even aan en zeg of er ergens iets schort, heb het niet getest

Code:

Global Dict1, Dict2

Sub MijnFotos()

   mypath = Sheets("foto").Range("M1").Value     'in deze directory en onderliggende zoeken
   mijndir = Filter(Split(CreateObject("WScript.Shell").Exec("cmd /c dir /b /s /ad " & mypath).StdOut.ReadAll, vbCr), mypath, 1)   'alle subdirectories
   mijnfiles = Filter(Split(CreateObject("WScript.Shell").Exec("cmd /c dir " & mypath & "/b /s").StdOut.ReadAll, vbCr), "_A.jpg", 1, vbTextCompare)   'alle "_A.jpg"-bestanden in die subdrectories

   Set Dict1 = CreateObject("scripting.dictionary") 'aanmaak 2 dictionaries
   Set Dict2 = CreateObject("scripting.dictionary")

   Const iMax = 1000 'om de 1000, de dictionary dumpen

   MsgBox "er zijn :" & vbLf & "- " & UBound(mijndir) + 1 & " subdirectories" & vbLf & "- " & UBound(mijnfiles) + 1 & " _A.jpg-bestanden"

   Sheets("foto").Range("A2").Resize(100000).ClearContents
   Sheets("geen foto").Range("A2").Resize(100000).ClearContents

   For i = 0 To UBound(mijndir)                  'alle subdirectories aflopen
      If Len(mijndir(i)) > 1 Then                'niet in de root
         flt = Filter(mijnfiles, mijndir(i), 1, vbTextCompare)   'alle bestanden in die subdirectory
         b = False                               'vlaggetje resetten
         If UBound(flt) <> -1 Then               'zitten er bestanden in
            For j = 0 To UBound(flt)             'al die bestanden aflopen
               sp = Split(flt(j), "\")           'splitten op "\"
               b = (sp(UBound(sp) - 1) = Left(sp(UBound(sp)), Len(sp(UBound(sp))) - 6))   'komt het voorlaatste stuk overeen met het eerste deel van het laatste stuk ?
               If b Then Exit For                'indien ja, goed bestand gevonden en klaar
            Next
         End If

         If b Then
            Dict1.Add Dict1.Count, Replace(mydir(i), mypath & "\", "")   'voeg subdirectory toe aan de goeie (enkel laatste stuk)
            If Dict1.Count > iMax Then Dumpen 1
         Else
            Dict2.Add Dict2.Count, Replace(mydir(i), mypath & "\", "")   'voeg subdirectory toe aan de slechte
            If Dict2.Count > iMax Then Dumpen 2
         End If
      End If
   Next

   Dumpen 1
   Dumpen 2
   
   End Sub

Sub Dumpen(nr)
   If nr = 1 Then
      If Dict1.Count Then
         Sheets("foto").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(Dict1.Count).Value = Application.Transpose(Dict1.items)
         Dict1.RemoveAll
      End If
   Else
      If Dict2.Count Then
         Sheets("geen foto").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(Dict2.Count).Value = Application.Transpose(Dict2.items)
         Dict2.RemoveAll
      End If
   End If
End Sub

BART1988 · 28 apr 2020

Schoonheidsfoutje

Code:

mydir

moet zijn

Code:

mijndir

, éénmaal dit aangepast loopt de macro als een trein...

Verbetering tegenover vorige code, bij deze staan in het tabblad "Geen foto", allemaal de correcte nummers en niet #NB
Alleen blijft in het tabblad "Foto" nog steeds vanaf rij 12847, #NB staan, dit geldt wel ENKEL voor kolom D (mijn subdirectories)

De weggeschreven nummers, als ik deze selecteer zie ik deze niet vanboven in de formulebalk en als ik deze kopieer naar ergens anders komt er steeds voor en na de nummer een " te staan..

Is deze code nu onbeperkt in aantallen?

Mvg

cow18 · 28 apr 2020

komt er van als je uit de losse pols zonder omkijken verandert.
In de vorige versie schreef ik niets naar D, dus alles wat daar stond was nog van de vorige keer.
Dus in deze versie wordt die ook per 1.000 weggeschreven.
Straks mag je anders eens stoeien met onderstaande regel. Maak daar anders eens 10.000, 20.000, 50.000, 65.000, ... (wel zonder punt) van en weet eens te zeggen vanaf wanneer je die NB krijgt.
Soms heb ik het idee, dat het niet zo vast ligt, zoals hierboven door mede-posters wordt aangegeven.

Code:

 Const iMax = 1000                             'om de 1000, de dictionary dumpen

nieuwe versie, nu wel met mijndir

Code:

Global Dict1, Dict2, Dict3

Sub MijnFotos()

   mypath = Sheets("foto").Range("M1").Value     'in deze directory en onderliggende zoeken
   mijndir = Filter(Split(CreateObject("WScript.Shell").Exec("cmd /c dir /b /s /ad " & mypath).StdOut.ReadAll, vbCr), mypath, 1)   'alle subdirectories
   mijnfiles = Filter(Split(CreateObject("WScript.Shell").Exec("cmd /c dir " & mypath & "/b /s").StdOut.ReadAll, vbCr), "_A.jpg", 1, vbTextCompare)   'alle "_A.jpg"-bestanden in die subdrectories

   Set Dict1 = CreateObject("scripting.dictionary")   'aanmaak 2 dictionaries
   Set Dict2 = CreateObject("scripting.dictionary")
   Set Dict3 = CreateObject("scripting.dictionary")

   Const iMax = 1000                             'om de 1000, de dictionary dumpen

   MsgBox "er zijn :" & vbLf & "- " & UBound(mijndir) + 1 & " subdirectories" & vbLf & "- " & UBound(mijnfiles) + 1 & " _A.jpg-bestanden"

   Sheets("foto").UsedRange.Offset(1).Resize(, 5).ClearContents
   Sheets("geen foto").Range("A2").Resize(100000).ClearContents

   For i = 0 To UBound(mijndir)                  'alle subdirectories aflopen
      If Len(mijndir(i)) > 1 Then                'niet in de root
         Dict3.Add Dict3.Count, Replace(mijndir(i), mypath & "\", "")   'voeg subdirectory toe aan de goeie (enkel laatste stuk)
         If Dict3.Count > iMax Then Dumpen 3

         flt = Filter(mijnfiles, mijndir(i), 1, vbTextCompare)   'alle bestanden in die subdirectory
         b = False                               'vlaggetje resetten
         If UBound(flt) <> -1 Then               'zitten er bestanden in
            For j = 0 To UBound(flt)             'al die bestanden aflopen
               sp = Split(flt(j), "\")           'splitten op "\"
               b = (sp(UBound(sp) - 1) = Left(sp(UBound(sp)), Len(sp(UBound(sp))) - 6))   'komt het voorlaatste stuk overeen met het eerste deel van het laatste stuk ?
               If b Then Exit For                'indien ja, goed bestand gevonden en klaar
            Next
         End If

         If b Then
            Dict1.Add Dict1.Count, Replace(mijndir(i), mypath & "\", "")   'voeg subdirectory toe aan de goeie (enkel laatste stuk)
            If Dict1.Count > iMax Then Dumpen 1
         Else
            Dict2.Add Dict2.Count, Replace(mijndir(i), mypath & "\", "")   'voeg subdirectory toe aan de slechte
            If Dict2.Count > iMax Then Dumpen 2
         End If
      End If
   Next

   Dumpen 1
   Dumpen 2
   Dumpen 3


   With Sheets("foto").Range("D2")               'voor de volledigheid hier ook even eea wegschrijven

      If UBound(mijnfiles) <> -1 Then
         With .Offset(, 1).Resize(UBound(mijnfiles) + 1)
            .Value = Application.Transpose(Split(Replace(Join(mijnfiles, "|"), mypath & "\", ""), "|"))
            .Interior.ColorIndex = kleur
         End With
      End If
   End If
   '.EntireRow.EntireColumn.AutoFit
End With

End Sub

Sub Dumpen(nr)
   Select Case nr
      Case 1
         If Dict1.Count Then
            Sheets("foto").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(Dict1.Count).Value = Application.Transpose(Dict1.items)
            Dict1.RemoveAll
         End If

      Case 2
         If Dict2.Count Then
            Sheets("geen foto").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(Dict2.Count).Value = Application.Transpose(Dict2.items)
            Dict2.RemoveAll
         End If

      Case 3
         If Dict3.Count Then
            Sheets("foto").Range("D" & Rows.Count).End(xlUp).Offset(1).Resize(Dict3.Count).Value = Application.Transpose(Dict3.items)
            Dict3.RemoveAll
         End If
   End Select
End Sub

BART1988 · 28 apr 2020

Straks mag je anders eens stoeien met onderstaande regel

Nu werkt de macro dus helemaal...Ik krijg op beiden tabbladen in geen enkele rij nog #NB, enkel de gevraagde nummers. Top!!!!
Dus moet ik deze waardes nog aanpassen, om eventueel wat te testen? Gaat de macro dan sneller gaan, of?

Code:

Sheets("geen foto").Range("A2").Resize(100000).ClearContents

Wil deze .Resize(100000) zeggen dat de macro enkel de 100.000 eerste mappen gaat doorlopen? Zo ja dan verhoog ik dit getal (voor in de toekomst)…

Kan alles wat weggeschreven wordt beginnen vanaf lijn A3 in tabblad "foto"?
Pas ik dit hier aan?

Code:

Sheets("foto").UsedRange.Offset(1).Resize(, 5)

En waar kan ik kolom D en E omdraaien? Is dan makkelijker leesbaar...

Alleen het probleem van het kopiëren stelt zich nog.

Bedankt alvast!

EDIT: Heb er wel nog een enkele End IF moeten uithalen.

cow18 · 28 apr 2020

neen, je vergist je, die dient om de eerste 100.000 cellen in de A-kolom van "Niet foto" leeg te maken.
Het gaat hem over der onderstaande rode iMax

Sorry voor dat end if-je, als je niet kan testen ...

Code:

Set Dict1 = CreateObject("scripting.dictionary")   'aanmaak 2 dictionaries
   Set Dict2 = CreateObject("scripting.dictionary")
   Set Dict3 = CreateObject("scripting.dictionary")

   Const iMax = [COLOR="#FF0000"][SIZE=4]1000[/SIZE][/COLOR]                             'om de 1000, de dictionary dumpen

   MsgBox "er zijn :" & vbLf & "- " & UBound(mijndir) + 1 & " subdirectories" & vbLf & "- " & UBound(mijnfiles) + 1 & " _A.jpg-bestanden"

als je niets aan de layout verandert dan maakt onderstaande regel A2 tot E2 en alle onderliggende rijen leeg.IK weet niet of dat nu nog wel mag ???
Bij het dumpen wordt altijd de rij volgend op de laatste gevulde rij gebruikt.
Door de rode regel toe te voegen na die clearcontents, zet je snel iets in A4, dus wordt er pas vanaf A5 gedumpt

Code:

Sheets("foto").UsedRange.Offset(1).Resize(, 5)...........
[COLOR="#FF0000"]Sheets("foto").range("A4").value="."[/COLOR]

BART1988 · 28 apr 2020

Sorry voor dat end if-je, als je niet kan testen ..

Geen probleem, ik ben al goed geholpen.

Ik ben niet echt mee met de rest, maar heb je regel eens toegevoegd, zonder het gewenste resultaat...

Alles wat hij wegschrijft zou gewoon pas mogen beginnen van rij 3 (A3,D3 en E3).

Bij die "Case" schrijf je nu ook weg naar kolom D, moet dit dan ook niet naar kolom E gebeuren?

Waar pas ik aan dat de gegevens van kolom E in kolom D moeten worden weggeschreven en andersom?

cow18 · 28 apr 2020

hier schrijf je weg naar de E-kolom,
Bovenste rode = D2
met de 2e rode zeg je .offset(,1) = 1 kolom naar rechts, dus E2
Maak van die D2, dan een D3
of anders moet ik daar ook een dictionary van maken zoals de anderen

Code:

[COLOR="#FF0000"]With Sheets("foto").Range("D2") [/COLOR]              'voor de volledigheid hier ook even eea wegschrijven

      If UBound(mijnfiles) <> -1 Then
         [COLOR="#FF0000"]With .Offset(, 1).Resize(UBound(mijnfiles) + 1)[/COLOR]
            .Value = Application.Transpose(Split(Replace(Join(mijnfiles, "|"), mypath & "\", ""), "|"))
            .Interior.ColorIndex = kleur
         End With
      End If

cow18 · 28 apr 2020

Code:

Sub Dumpen(nr)
   Select Case nr
      Case 1
         If dict1.Count Then
            With Sheets("foto")
               If IsEmpty(.Range("A2")) Then .Range("A2").Value = "'"   'staat er niets in A2, zet er dan iets in, zodat er pas gedumpd wordt vanaf A3
               .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(dict1.Count).Value = Application.Transpose(dict1.items)
               dict1.RemoveAll
            End With
         End If

      Case 2
         If dict2.Count Then
            With Sheets("geen foto")
               If IsEmpty(.Range("A2")) Then .Range("A2").Value = "'"
               .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(dict2.Count).Value = Application.Transpose(dict2.items)
               dict2.RemoveAll
            End With
         End If

      Case 3
         If dict3.Count Then
            With Sheets("foto")
               If IsEmpty(.Range("D2")) Then .Range("D2").Value = "'"
               .Range("D" & Rows.Count).End(xlUp).Offset(1).Resize(dict3.Count).Value = Application.Transpose(dict3.items)
               dict3.RemoveAll
            End With
         End If
   End Select
End Sub

BART1988 · 28 apr 2020

Ik had van de "D2" al "D3" gemaakt...Maar deed precies niet veel...

Wel erg bedankt voor de moeite en uitleg...

EDIT: Niet gezien dat je nog iets gepost had, eerst eens uitproberen...
EDIT2: Getest en goedgekeurd, bedankt!!!!!!

BART1988 · 29 apr 2020

Code:

      Case 3
         If dict3.Count Then
            With Sheets("foto")
               If IsEmpty(.Range("D2")) Then .Range("D2").Value = "'"
               .Range("D" & Rows.Count).End(xlUp).Offset(1).Resize(dict3.Count).Value = Application.Transpose(dict3.items)
               dict3.RemoveAll
            End With
         End If
   End Select
End Sub

Als ik hier van alle D's, E's maak en van .Offset(1), .Offset(-1) maak.
Zijn de weggeschreven gegevens van kolom D en E dan omgewisseld?
Ik zou deze omgedraaid willen hebben...

cow18 · 29 apr 2020

ok om om te wisselen maak je in die Case 3 alle D's E's.
om die E een D te maken, schrap je gewoon die ".offset(,1)" van reactie #56.
Met .offset(,-1) zou je tov de D-kolom 1 naar links gaan, dus de C-kolom, maar je wilde in D-blijven

Foto's zoeken

Gebruiker

Terugkerende gebruiker

Gebruiker

Terugkerende gebruiker

Gebruiker

Inventaris

Gebruiker

Verenigingslid

Gebruiker

Terugkerende gebruiker

Gebruiker

Terugkerende gebruiker

Gebruiker

Terugkerende gebruiker

Gebruiker

Terugkerende gebruiker

Terugkerende gebruiker

Gebruiker

Gebruiker

Terugkerende gebruiker

Wij waarderen jouw privacy