• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Waarden uit verschillende exelbestand in document laden

Status
Niet open voor verdere reacties.

Fosters

Gebruiker
Lid geworden
26 jul 2010
Berichten
60
Beste forumgebruikers,

In een map heb ik diverse excelbestanden staan met allemaal dezelfde structuur (facturen bijvoorbeeld). In elk excelbestand zijn er twee cellen met een datum er in. Dit zijn de ontvangstdatum en een einddatum.
Het aantal bestanden in de map varieert continu.

Is er een mogelijkheid om een 'overall-bestand' te maken, dat uit alle bestanden in deze map de twee datums haalt? Dus dat ik in een oogopslag zie welke facturen er in de map staan met welke data hier aan gekoppelt zijn?

Met name het automatisch ophalen van deze waarden heb ik zo mijn twijfels bij... :confused:
 
Je kunt met VBA de gegevens ophalen zonder dat de bestanden behoeven te worden geopend.

Er zijn dan nog 2 dingen nodig:
- De celadressen van de 2 datums of een leeg voorbeeldbestand.
- Het pad van de directory.

Met vriendelijke groet,


Roncancio
 
Roncancio,

Ik had de hoop al bijna opgegeven. :thumb:
De 2 cellen waarvan ik de waarde in een bestand wil laden zijn: H13 en H14
Het pad met de bestanden is G:\Ruimte\Vergunningen\

Ik ben benieuwd of het lukt!

Bedankt in elk geval!
 
Code:
Sub Ophalen()

Set fs = CreateObject("Scripting.filesystemobject")
Set Pad = fs.getfolder("G:\Ruimte\Vergunningen")
For Each bestand In Pad.Files
    If LCase(bestand) Like "*.xls" Then
        R = R + 1
        Range(" A" & R).Value = Mid(bestand, Len(Pad) + 2, Len(bestand))
        Range(" B" & R).Value = ExecuteExcel4Macro("'" & Pad & "\[" & Range(" A" & R).Value & "][B][COLOR="red"]Blad1[/COLOR][/B]'!R13C8")
        Range(" C" & R).Value = ExecuteExcel4Macro("'" & Pad & "\[" & Range(" A" & R).Value & "][B][COLOR="red"]Blad1[/COLOR][/B]'!R14C8")
    End If
Next
End Sub

Ik was nog vergeten te zeggen dat je nog de naam van het werkblad moet aanpassen.
(rode tekst).
Het resultaat van de macro is:
naam bestand [H13] [H14]

Met vriendelijke groet,


Roncancio
 
Super bedankt! Ik heb de tabbladen toegevoegd. Met deze code werkt de functie zoals ik gehoopt had.

Code:
Sub Ophalen()

Set fs = CreateObject("Scripting.filesystemobject")
Set Pad = fs.getfolder("G:\Ruimte\Vergunningen")
For Each bestand In Pad.Files
    If LCase(bestand) Like "*.xls" Then
        R = R + 1
        Range(" A" & R).Value = Mid(bestand, Len(Pad) + 2, Len(bestand))
        Range(" B" & R).Value = ExecuteExcel4Macro("'" & Pad & "\[" & Range(" A" & R).Value & "]Dashboard'!R13C8")
        Range(" C" & R).Value = ExecuteExcel4Macro("'" & Pad & "\[" & Range(" A" & R).Value & "]Dashboard'!R14C8")
    End If
Next
End Sub

Ik zou het document nu alleen meer opmaak willen geven, waardoor er niet gestart moet worden bij A1, maar bijvoorbeeld bij A5... Hoe verwerk ik dit in de formule?

Groet!
 
Code:
Sub Ophalen()
Dim lRij As Long
    Set fs = CreateObject("Scripting.filesystemobject")
    Set Pad = fs.getfolder("G:\Ruimte\Vergunningen")
    lRij = 5
    For Each bestand In Pad.Files
        If LCase(bestand) Like "*.xls" Then
            Range(" A" & lRij).Value = Mid(bestand, Len(Pad) + 2, Len(bestand))
            Range(" B" & lRij).Value = ExecuteExcel4Macro("'" & Pad & "\[" & Range(" A" & lRij).Value & "]Dashboard'!R13C8")
            Range(" C" & lRij).Value = ExecuteExcel4Macro("'" & Pad & "\[" & Range(" A" & lRij).Value & "]Dashboard'!R14C8")
        End If
        lRij = lRij + 1
    Next
End Sub

Met vriendelijke groet,


Roncancio
 
Dank voor de snelle reactie.

Nu nog een laatste aanpassing. Ik zou graag een derde waarde uit de excelbestanden halen. In kolom F wil ik alle waarden uit B137 van het tablad 'Dashboard' :thumb:

Echt enorm bedankt! Eindelijk krijg ik de puzzel kloppend!
 
Laatst bewerkt:
Code:
Sub Ophalen()
Dim lRij As Long
    Set fs = CreateObject("Scripting.filesystemobject")
    Set Pad = fs.getfolder("G:\Ruimte\Vergunningen")
    lRij = 5
    For Each bestand In Pad.Files
        If LCase(bestand) Like "*.xls" Then
            Range("A" & lRij).Value = Mid(bestand, Len(Pad) + 2, Len(bestand))
            Range("B" & lRij).Value = ExecuteExcel4Macro("'" & Pad & "\[" & Range(" A" & lRij).Value & "]Dashboard'!R13C8")
            Range("C" & lRij).Value = ExecuteExcel4Macro("'" & Pad & "\[" & Range(" A" & lRij).Value & "]Dashboard'!R14C8")
            Range("F" & lRij).Value = ExecuteExcel4Macro("'" & Pad & "\[" & Range(" A" & lRij).Value & "]Dashboard'!R74C2")
        End If
        lRij = lRij + 1
    Next
End Sub

Met vriendelijke groet,


Roncancio
 
Mijn dag is goed! Nogmaals bedankt!

Het kwartje is nu ook gevallen met R13C8, R14C8 en R137C2... daar liep het bij mij mis:confused:
 
Graag nog de vraag op opgelost zetten.

Met vriendelijke groet,


Roncancio
 
Toch nog even een vraag...
Momenteel worden de bestandsnamen ingeladen in het excelbestand. Is het ook mogelijk automatisch een link aan te maken tussen deze ingelade bestandsnaam en het bestand dat erbij hoort?
 
Ongetest.
De hyperlinks worden eerst verwijderd mochten ze al aanwezig zijn.
Vervolgens worden de hyperlinks toegevoegd.
Code:
Sub Ophalen()
Dim lRij As Long
    Set fs = CreateObject("Scripting.filesystemobject")
    Set Pad = fs.getfolder("G:\Ruimte\Vergunningen")
    lRij = 5
    Cells.Hyperlinks.Delete
    For Each Bestand In Pad.Files
        If LCase(Bestand) Like "*.xls" Then
            Range("A" & lRij).Value = Mid(Bestand, Len(Pad) + 2, Len(Bestand))
            ActiveSheet.Hyperlinks.Add Range("A" & lRij), Mid(Bestand, Len(Pad) + 2, Len(Bestand)), , Bestand
            Range("B" & lRij).Value = ExecuteExcel4Macro("'" & Pad & "\[" & Range(" A" & lRij).Value & "]Dashboard'!R13C8")
            Range("C" & lRij).Value = ExecuteExcel4Macro("'" & Pad & "\[" & Range(" A" & lRij).Value & "]Dashboard'!R14C8")
            Range("F" & lRij).Value = ExecuteExcel4Macro("'" & Pad & "\[" & Range(" A" & lRij).Value & "]Dashboard'!R137C2")
        End If
        lRij = lRij + 1
    Next
End Sub

Met vriendelijke groet,


Roncancio
 
Ik heb je code ingevoegd, maar op regel 10 (ActiveSheet.Hyperlinks...) krijg ik een foutmelding.

Code:
Sub Ophalen()
Dim lRij As Long
    Set fs = CreateObject("Scripting.filesystemobject")
    Set Pad = fs.getfolder("C:\Documents and Settings\tvossen\Bureaublad\00Wabo-zaakdossier")
    lRij = 10
    Cells.Hyperlinks.Delete
    For Each Bestand In Pad.Files
        If LCase(Bestand) Like "*.xls" Then
            Range(" B" & lRij).Value = Mid(Bestand, Len(Pad) + 2, Len(Bestand))
            ActiveSheet.Hyperlinks.Add Range("B" & lRij), Mid(Bestand, Len(Pad) + 2, Len(Bestand)), , Bestand
            Range(" C" & lRij).Value = ExecuteExcel4Macro("'" & Pad & "\[" & Range(" B" & lRij).Value & "]Dashboard'!R13C8")
            Range(" D" & lRij).Value = ExecuteExcel4Macro("'" & Pad & "\[" & Range(" B" & lRij).Value & "]Dashboard'!R14C8")
            Range(" G" & lRij).Value = ExecuteExcel4Macro("'" & Pad & "\[" & Range(" B" & lRij).Value & "]Dashboard'!R137C2")
        End If
        lRij = lRij + 1
    Next
End Sub
 
Aangepast en nu wel getest.

Code:
Sub Ophalen()
Dim lRij As Long
    Set fs = CreateObject("Scripting.filesystemobject")
    Set Pad = fs.getfolder("C:\Documents and Settings\tvossen\Bureaublad\00Wabo-zaakdossier")

    lRij = 10
    Cells.Hyperlinks.Delete
    For Each bestand In Pad.Files
        If LCase(bestand) Like "*.xlsx" Then
            Range(" B" & lRij).Value = Mid(bestand, Len(Pad) + 2, Len(bestand))
            ActiveSheet.Hyperlinks.Add Range("B" & lRij), bestand
            Range(" C" & lRij).Value = ExecuteExcel4Macro("'" & Pad & "\[" & Range(" B" & lRij).Value & "]Dashboard'!R13C8")
            Range(" D" & lRij).Value = ExecuteExcel4Macro("'" & Pad & "\[" & Range(" B" & lRij).Value & "]Dashboard'!R14C8")
            Range(" G" & lRij).Value = ExecuteExcel4Macro("'" & Pad & "\[" & Range(" B" & lRij).Value & "]Dashboard'!R137C2")
        End If
        lRij = lRij + 1
    Next
End Sub

Met vriendelijke groet,


Roncancio
 
Status
Niet open voor verdere reacties.
Terug
Bovenaan Onderaan