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

    Dit is een verouderd onderwerp. Heb je een gelijkaardige vraag? Start dan een nieuw topic in dit forumonderdeel aub.

    Doe mee aan dit gesprek

    Je kunt dit nu plaatsen en later registreren. Indien je reeds een account hebt, log dan nu in om het bericht te plaatsen met je account.

    Gast
    Reageer op dit topic

    ×   Geplakt als verrijkte tekst.   Plak in plaats daarvan als platte tekst

      Er zijn maximaal 75 emoji toegestaan.

    ×   Je link werd automatisch ingevoegd.   Tonen als normale link

    ×   Je vorige inhoud werd hersteld.   Leeg de tekstverwerker

    ×   Je kunt afbeeldingen niet direct plakken. Upload of voeg afbeeldingen vanaf een URL in


    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!

    ×
    ×
    • Nieuwe aanmaken...

    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.