Ga naar inhoud

Welkom op PC Helpforum!
PC Helpforum helpt GRATIS computergebruikers sinds 2006. Ons team geeft via het forum professioneel antwoord op uw vragen en probeert uw pc problemen zo snel mogelijk op te lossen. Word lid vandaag, plaats je vraag online en het PC Helpforum-team helpt u graag verder!

Vriendelijk verzoek: whitelist www.pc-helpforum.be in je adblocker.

Beste bezoeker. Je ziet deze tekst omdat een adblocker, plugin of andere software onze advertenties blokkeert. PC Helpforum helpt jaarlijks gratis duizenden mensen met computerproblemen. Deze website en server kunnen we enkel onderhouden dankzij de inkomsten uit advertenties. Vandaar een vriendelijk verzoek: whitelist onze site zodat we jullie gratis verder kunnen helpen. Klik hier om te lezen waarom en hoe je kunt whitelisten.



janlazeure

emailadressen uit meedere excel bestanden extraheren

    Aanbevolen berichten

    Beste,

     

    ik wil de emailadressen uit 500 excel bestanden extraheren. Deze mailadressen staan op telkens op het tweede tabblad op cel B11. Nu had ik al een VBA code als volgt :

    Sub ConsolidateAll()
        Dim rsCon As Object, rsData As Object, sFileName As String
        Dim Prov As String, ExProp As String, resarr ', wDir As String
        Const wDir = "C:\Database\"
        Prov = IIf(Val(Application.Version) < 12, "Microsoft.Jet.OLEDB.4.0", "Microsoft.ACE.OLEDB.12.0")
        ExProp = IIf(Val(Application.Version) < 12, "8.0", "12.0")
        Sheets(1).Cells(1).CurrentRegion.Offset(1).ClearContents
        sFileName = Dir(wDir & "*.xlsx")
        Do While sFileName <> ""
            If sFileName <> ThisWorkbook.Name Then
                Set rsCon = CreateObject("ADODB.Connection"): Set rsData = CreateObject("ADODB.Recordset")
                rsCon.Open "Provider=" & Prov & ";Data Source=" & wDir & sFileName & _
                                ";Extended Properties=""Excel " & ExProp & ";HDR=No"";"
                rsData.Open "SELECT * FROM [Personalia$B11];", rsCon, 0, 1, 1
                If Not rsData.EOF Then
                    resarr = rsData.GetRows
                End If
                Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(resarr, 1) + 1, UBound(resarr, 2) + 1) = resarr
                sFileName = Dir: rsData.Close: Set rsData = Nothing: rsCon.Close: Set rsCon = Nothing
            End If
        Loop
    End Sub
     

    Maar bij het ophalen krijg ik steeds de melding dat hij het tabblad personalia B11 niet kan vinden.

    In bijlage de beide bestanden (bron bestand waar de info staat en database bestand waar de mail adressen in moeten komen

    Kan iemand mij asap hierbij helpen aub?

     

    Alvast bedankt

    aagje pype.xlsx

    Database.xlsm

    Deel dit bericht


    Link naar bericht
    Delen op andere sites

    Ter Info voor de helpers: janlazeure heeft nog 2 andere topics open staan waar heel sterk gelijkende vragen worden gesteld.

    Volgens mij hebben al deze topics met elkaar te maken en riskeren we (jullie) dubbel werk te doen.

     

    @janlazeure

    Als de andere topics opgelost zijn en mogen afgesloten worden, laat het dan weten in het betreffende topic.

    Als deze nieuwe vraag aansluit bij een van de andere topics, laat dan weten bij welk topic het hoort en dan voegen we de beide topics samen.

    Deel dit bericht


    Link naar bericht
    Delen op andere sites
  • Topicstarter
  •    0

    beste, de vorige twee zijn opgelost, dit betreft een nieuwe vraag, excuses als dit niet werd duidelijk gemaakt

    deze heb ik vandaag eigenlijk dringend nodig, de rest werk ik zelf verder aan

    mvg

    Deel dit bericht


    Link naar bericht
    Delen op andere sites

    Deze heb ik je ook al eens eerder gegeven.
     

    Sub UpdateBestanden()
    
    Dim FilePath$, Row&, Column&, Address$
    'change constants & FilePath below to suit
          '***************************************
         
          Const SheetName$ = "Personalia"
          Address = Cells(11, 2).Address
          FilePath = "D:\Test2\"
          '***************************************
        With CreateObject("scripting.filesystemobject").getfolder(FilePath)
            For Each fl In .Files
                If Right(fl.Name, 5) = ".xlsx" Then
                    Cells(Rows.Count, 1).End(xlUp).Offset(1) = fl.Name
                    Filename = fl.Name
                    Cells(Rows.Count, 1).End(xlUp).Offset(0, 1) = GetData(FilePath, Filename, SheetName, Address)
                    Columns.AutoFit
                End If
            Next
        End With
    End Sub
    
    Private Function GetData(path, file, sheet, Address)
          Dim Data$
          Data = "'" & path & "[" & file & "]" & sheet & "'!" & _
                Range(Address).Range("A1").Address(, , xlR1C1)
          GetData = ExecuteExcel4Macro(Data)
    End Function

     

    Deel dit bericht


    Link naar bericht
    Delen op andere sites

    een uitroepingsteken vergeten achter Personalia

     

     

     rsData.Open "SELECT * FROM [Personalia!$B11];", rsCon, 0, 1, 1

     

    Deel dit bericht


    Link naar bericht
    Delen op andere sites

    Maak een account aan of log in om te reageren

    Je moet een lid zijn om een reactie te kunnen achterlaten

    Account aanmaken

    Registreer voor een nieuwe account in onze community. Het is erg gemakkelijk!

    Registreer een nieuwe account

    Inloggen

    Heb je reeds een account? Log hier in.

    Nu inloggen

    Logo

    OVER ONS

    PC Helpforum helpt GRATIS computergebruikers sinds juli 2006. Ons team geeft via het forum professioneel antwoord op uw vragen en probeert uw pc problemen zo snel mogelijk op te lossen. Word lid vandaag, plaats je vraag online en het PC Helpforum-team helpt u graag verder!

    ×

    Belangrijke informatie

    We hebben cookies geplaatst op je toestel om deze website voor jou beter te kunnen maken. Je kunt de cookie instellingen aanpassen, anders gaan we er van uit dat het goed is om verder te gaan.