Celwaarde zoeken in alle excelbestanden in een directory

[R2Grafix]

Goedendag,

We hebben een excelbestand voor het verwerken van orders. Elke order is een apart exceldocument.
Nu moet ik voor een klant een overzicht maken van gebruikte gereedschappen van een x-aantal jaren.
Die gereedschappen worden in elke orderbestand in blad2 (Werkbon) op positie C37 genoteerd.
Is er een VBA-code of anderszins om alle orderbestanden in een directory automatisch af te zoeken naar de waarde in Map2-C37 en de gevonden waarden op te slaan in een aparte lijst?
Ben zeer benieuwd, want als dit kan scheelt dan enorm veel muisklikken.
Dank alvast

 

[VenA]

Als de bestanden in dezelfde map staan dan kan je zoiets proberen

Sub VenA()
  Application.ScreenUpdating = 0
  c00 = "E:\Temp\Temp\"
  Set fc = CreateObject("Scripting.FileSystemObject").GetFolder(c00).Files
  Set d = CreateObject("Scripting.Dictionary")
    On Error Resume Next
    For Each f In fc
      With GetObject(f.Path)
        d(f.Name) = .Sheets(2).Range("C37").Value
        .Close 0
      End With
    Next f
    Cells(1).Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
End Sub

 

[HSV]

Veel meer snelheid erin kan nooit kwaad.

Sub hsv()
Application.ScreenUpdating = 0
Application.DisplayAlerts = False
Set d = CreateObject("Scripting.Dictionary")
  s0 = "E:\Temp\Temp\"
  bestandopen = Dir(s0 & "*")
  Do Until bestandopen = ""
    With Workbooks.Open(s0 & bestandopen)
        d(.Name) = .Sheets(2).Range("C37").Value
       .Close 0
    End With
    bestandopen = Dir
  Loop
  Cells(1).Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
End Sub

Of:

Sub hsv_2()
ReDim a(1, 0)
Application.ScreenUpdating = 0
Application.DisplayAlerts = False
  s0 = "E:\Temp\Temp\"
  bestandopen = Dir(s0 & "*")
  Do Until bestandopen = ""
    With Workbooks.Open(s0 & bestandopen)
        a(0, j) = .Name
        a(1, j) = .Sheets(2).Range("C37").Value
             j = j + 1
        ReDim Preserve a(1, j)
      .Close 0
    End With
    bestandopen = Dir
  Loop
 Cells(1).Resize(j, 2) = Application.Transpose(a)
End Sub

 

[R2Grafix]

Hartelijk dank
De eerste van VenA doet zijn werk.
Bij de twee andere mogelijkheden krijg ik een error. de eerste geeft aan dat typen niet overeen komen, de andere geeft fout 1004/
Ik heb een paar proefbestandjes in een map gezet en getest en dit helpt me enorm.
Meer snelheid is mooi, maar VenA werkt en daarmee ben ik enorm geholpen

 

[HSV]

Werkt hier uitstekend, hetzelfde resultaat maar zeker 3 tot 4 keer sneller.

 

[VenA]

@HSV,
Fascinerende uitspraak dat jouw code 3 tot 4 keer sneller is. Aan jouw codes heb ik ook een On Error Resume Next toegevoegd om de code niet te laten struikelen. (Zal normaal gesproken niet nodig moeten zijn) maar met 12 willekeurige bestandjes in de map, die ik niet heb aangepast naar de situatie van de TS, was dat even nodig. Ik kom dan tot een heel andere conclusie.

 

[HSV]

Fascinerend maar niet gesproken.

Het resultaat van 12 bestanden hier.

HSV → 4,156
HSV_2 → 4,163
V&A → 15,730

 

[Timshel]

Fittie


Heb ook een arbitraire test gedaan met bijgevoegd resultaat (12 testbestandjes met 2 tabbladen en alleen cel C37 gevuld). De belangrijkste conclusie lijkt me dat de scores nogal kunnen variëren per machine. Je zou denken dat het openen en sluiten van bestanden de bottleneck is maar kennelijk maakt de gebruikte methode toch verschil.