Ophalen cel waarde uit meerdere gesloten Excel bestanden (VBA)

[vvermeer]

Beste lezers,

Voor mijn werk ben ik bezig met het maken van een algemene database in 1 nieuw Excel bestand. Hiervoor moet ik uit ca. 580 gesloten bestanden verschillende waarde ophalen. Na al veel gezocht te hebben op het internet hebben collega's en ik tevergeefs gezocht naar een werkende code (en deze ook aangepast). Helaas is het nog steeds niet werkend en zakt de moed een beetje in onze schoenen. Dit omdat tot nu aan toe de gehele database handmatig is gevuld, door middel van kopiëren en plakken. Echter door een fout is er een rij overgeslagen en moeten we deze nu weer 580 x kopiëren vanuit alle bestanden.

Het schijnt mogelijk te zijn met een VBA code al deze gegevens op te vragen. Daarom zouden wij graag gebruik maken van uw kennis omdat wij er zelf niet meer uit komen. Wat nu het meest van pas zou komen is een stukje VBA code waarmee de specifieke gegevens kunnen worden opgeroepen vanuit al deze (genummerde)bestanden. Als er een code zou zijn om de gehele database opnieuw te maken is dat natuurlijk ook erg fijn.

Met dit stukje code is onder andere geëxperimenteerd:

Sub ImportLotsOfFiles()
Dim lCount As Long
Dim vFilename As Variant
Dim sPath As String
Dim lFilecount As Long
vFilename = Application.GetOpenFilename("Microsoft Excel files (*.xlsm?),*.xlsm?", , _
"Selecteer de bestanden", , True)
If TypeName(vFilename) = "Boolean" Then Exit Sub
For lCount = LBound(vFilename) To UBound(vFilename)
Workbooks.Open vFilename(lCount)
With ThisWorkbook.Worksheets("Verzamel")
With .Range("A" & .Rows.Count).End(xlUp).Offset(1)
.Value = vFilename(lCount)
.Offset(, 1).Value = Range("F1").Value
.Offset(, 2).Value = Range("I50").Value
End With
End With
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
ActiveWorkbook.Close False
End If
Next
End Sub

Alvast erg bedankt,
Met vriendelijke groet,
Vincent Vermeer

 

[wampier]

en wat werkt er niet? het grootste probleem dat ik zie is dat "thisworkbook" op het moment van openen waarschijnlijk het nieuw geopende workbook is.

Het enige wat je dan echt aan moet passen is doel en bronbestand beter definiëren. Graag ook de code in

 tags plaatsen voor de leesbaarheid

 

[VenA]

Ik begrijp het nut niet helemaal waarom je met deze procedure alleen .XLSM bestanden vrij kan selecteren. Normaal gesproken zet je de files die je wil importeren in een map 'Import" en als het goed gegaan is zet je deze afhankelijk van de wensen in een ander map. Nu loop je nog steeds het risico dat je een file vergeet.

Deze doet volgens mij het gewenste

Sub ImportLotsOfFiles()
    vFilename = Application.GetOpenFilename("Microsoft Excel files (*.xlsm?),*.xlsm?", , _
    "Selecteer de bestanden", , True)
    If TypeName(vFilename) = "Boolean" Then Exit Sub
        For lCount = LBound(vFilename) To UBound(vFilename)
            With GetObject(vFilename(lCount))
                ThisWorkbook.Sheets("Verzamel").Range("A10000").End(xlUp).Offset(1).Resize(, 3) = Array(.Sheets(1).Range("F1"), .Sheets(1).Range("I50"), vFilename(lCount))
                .Close
            End With
    Next lCount
End Sub

 

[HSV]

En dan ga je 580 bestanden handmatig openen?
Stop ze allemaal bij elkaar in een map (incl. je verzamelbestand).

Sub hsv()
Dim bestandopen As String
Application.ScreenUpdating = False
 bestandopen = Dir(ThisWorkbook.Path & "\*")
    Do Until bestandopen = ""
    If ThisWorkbook.Name <> bestandopen Then
        Workbooks.Open ThisWorkbook.Path & "\" & bestandopen
       ThisWorkbook.Sheets("Verzamel").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 3) = Array(bestandopen, Sheets(1).Range("F1"), Sheets(1).Range("I50"))
 Workbooks(bestandopen).Close False
 End If
      bestandopen = Dir
  Loop
End Sub