excelbestand aanvullen met gegevens uit ander excelbestand

Public Sub ProcZoekTeams()

'Zoek basis van de kolom "Code Org.eenh" (Kolom C) in bestand "ID Teams.xlsx"
'De sector, afdeling en team.
'In ID teams staat de "Code Org.eenh." op sheet "Blad1" kolom B Sector in kolom C Afdeling in kolom D en Team in kolom E.
'Stappen om de gegevens op te zoeken:
'-Open bestand "ID Teams.xlsx"
'-Doorloop de kolom C in bestandmedewerkers van regel 2 t/m laatste regel van de kolom.
'   -Ga naar ID Teams.xlsx en zoek in sheet "Blad1" kolom B de juiste kode.
'   -Als gevonden
'       -Neem de gegevens op van de sector, afdeling en team.
'   -Anders
'       -Meld niet gevonden en ga door.
'   -Ga terug naar bestandmedewerkers en vul de gegevens in.
'-Ga naar de volgende regel in bestandmederwerks en herhaal.
'-Sluit bestand ID Teams.xlsx
'-Meld dat je klaar bent.
'----------------------------------------------------------------------------------------------------

Dim sCurPath As String  'Waar staat bestand ID Teams.xlsx
Dim fMedewerker As Workbook     'Alias voor bestand medewerker
Dim fIDTeams As Workbook        'Alias voor bestand ID Teams
Dim nRegel As Long              'Regelteller voor medewerkers
Dim sZoekTeam As String         'Zoekterm voor het team
Dim aAdress As Range            'Zoekresultaat in de vorm van een range

sCurPath = ActiveWorkbook.Path      'Hier eventueel aangeven waar het bestand "ID teams.xlsx" staat.

'Definieren bestand Medewerker
Set fMedewerker = ActiveWorkbook
'Open bestand "ID Teams.xlsx" Readonly
Set fIDTeams = Workbooks.Open(sCurPath & "\IDTeams.xlsx", , True)

'Doorloop  kolom C in bestand medewerkers
Do While fMedewerker.Sheets("Blad1").Range("C2").Offset(nRegel, 0) <> ""
    'Sla te zoeken bestand op in een variabele
    sZoekTeam = fMedewerker.Sheets("Blad1").Range("C2").Offset(nRegel, 0)
    'Zoek in kolom B naar de code in medewerker bestand
    Set aAdress = fIDTeams.Sheets("Blad1").Range("B2:B1000").Find(sZoekTeam, LookIn:=xlValues)
    If Not aAdress Is Nothing Then      'Code gevonden, gegevens overnemen.
        fMedewerker.Sheets("Blad1").Range("C2").Offset(nRegel, 1) = fIDTeams.Sheets("Blad1").Range(aAdress.Address).Offset(0, 1) 'Schrijf sector
        fMedewerker.Sheets("Blad1").Range("C2").Offset(nRegel, 2) = fIDTeams.Sheets("Blad1").Range(aAdress.Address).Offset(0, 2) 'Schrijf afdeling
        fMedewerker.Sheets("Blad1").Range("C2").Offset(nRegel, 3) = fIDTeams.Sheets("Blad1").Range(aAdress.Address).Offset(0, 3) 'Schrijf team
    Else                                'Code niet gevonden
        MsgBox "Kode " & sZoekTeam & " komt niet voor in bestand ID Teams.", vbInformation, "Oeps!!"
    End If
    nRegel = nRegel + 1
Loop

'Bestand sluiten en rommel opruimen.
fIDTeams.Close
Set fIDTeams = Nothing
Set fMedewerker = Nothing

'Meld klaar
MsgBox "Klaar, er zijn " & nRegel & " regels opgezocht en ingevuld.", vbInformation, "Klaar!"

End Sub

Sub M_snb()
  sn = Sheet1.Cells(1).CurrentRegion
  sp = GetObject("J:\download\IDteams.xlsx").Sheets(1).UsedRange
    
  With CreateObject("scripting.dictionary")
    For j = 2 To UBound(sp)
      .Item(sp(j, 2)) = Application.Index(sp, j)
    Next
       
    For j = 2 To UBound(sn)
      sn(j, 4) = .Item(sn(j, 3))(3)
      sn(j, 5) = .Item(sn(j, 3))(4)
      sn(j, 6) = .Item(sn(j, 3))(5)
    Next
  End With
    
  Sheet1.Cells(1).CurrentRegion = sn
End Sub

Sub M_snb()
  sn = Sheet1.Cells(1).CurrentRegion
    
  With CreateObject("New:{8BD21D20-EC42-11CE-9E0D-00AA006002F3}")
    .List = GetObject("J:\download\IDteams.xlsx").Sheets(1).UsedRange.Value
    .TextColumn = 2
    For j = 2 To UBound(sn)
      .Text = sn(j, 3)
      sn(j, 4) = .Column(1)
      sn(j, 5) = .Column(2)
      sn(j, 6) = .Column(3)
    Next
  End With

  Sheet1.Cells(1).CurrentRegion = sn
End Sub

Sub M_snb()
  Sheets.Add(, Sheets(Sheets.Count), , "J:\download\IDteams.xlsx").Name = "IDteams"
    
  With CreateObject("ADODB.Recordset")
    .Open "SELECT Blad1$.Idnummer, Blad1$.naam, Blad1$.code, IDteams$.Sector, IDteams$.Afdeling, IDteams$.Naam FROM [Blad1$],  [IDteams$] where Blad1$.Code=IDteams$.Code ", "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=Yes;IMEX=1"""
    Sheet1.Cells(40, 1).CopyFromRecordset .DataSource
  End With
End Sub

Sub M_snb()
  Sheets.Add(, Sheets(Sheets.Count), , "J:\download\IDteams.xlsx").Name = "IDteams"
    
  With Sheet1.Cells(1).CurrentRegion
    .Columns(4).SpecialCells(4).Resize(, 3) = "=index(IDteams!C:C,match($C2,IDteams!$B:$B,0))"
    .Value = .Value
  End With
    
  Application.DisplayAlerts = False
  Sheets("IDteams").Delete
End Sub