emailadressen uit meedere excel bestanden extraheren

[janlazeure]

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

[kweezie wabbit]

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.

[janlazeure]

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

[bakerman]

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

 

[emielDS]

een uitroepingsteken vergeten achter Personalia

 

 

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

 

[kweezie wabbit]

22 uren geleden, janlazeure zei:

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

OK, dan sluiten we die af.