XL 2010 SOLVED: rechercher dans un autre fichier et copier cellule référence

' (c)XLSolutionS, (c)2017

Sub RecupCaBis()
Dim xlsWsRecap As Object
Dim nomFicClients

Dim derLig

Dim cptOng, nbrOng
Dim tabEts()

Dim nomEts
Dim numEts
Dim cptLig, cptTrv

Dim tpsDeb, tpsFin

  Set xlsWsRecap = Worksheets(ActiveSheet.Name)

  nomFicClients = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", Title:="Selectionnez le fichier Clients")
  If nomFicClients = "" Then
  MsgBox "annul"
  Else
  tpsDeb = Timer
  Application.ScreenUpdating = False

  Workbooks.Open (nomFicClients)
  nbrOng = Sheets.Count
  ReDim tabEts(1 To nbrOng, 1 To 2)
  For cptOng = 1 To nbrOng
  tabEts(cptOng, 1) = Sheets(cptOng).Cells(2, 1)
  tabEts(cptOng, 2) = Sheets(cptOng).Cells(59, 15)
  Next
  Windows(Dir(nomFicClients)).Close

  derLig = xlsWsRecap.Rows.Count
  cptLig = 0
  cptTrv = 0
  While Not (derLig = 2)
  If Not (xlsWsRecap.Cells(derLig, 11) = "") Then
  cptLig = cptLig + 1
  nomEts = xlsWsRecap.Cells(derLig, 11)
  numEts = TrouveEts(nomEts, tabEts)
  If numEts > 0 Then
  xlsWsRecap.Cells(derLig, 35) = tabEts(numEts, 2)
  cptTrv = cptTrv + 1
  Else
  xlsWsRecap.Cells(derLig, 35) = "ABS"
  End If
  End If
  derLig = derLig - 1
  Wend
  Application.ScreenUpdating = True

  tpsFin = Int(Timer - tpsDeb)

  MsgBox cptTrv & " Trouvés / " & cptLig & " Lignes" & vbCrLf & "en " & tpsFin & " sec.", vbOKOnly + vbInformation, "FIN"
  End If

  Set xlsWsRecap = Nothing

End Sub

Function TrouveEts(lequel, tablo)
Dim trvEts As Boolean
Dim cptEts

  trvEts = False
  cptEts = 1
  While Not (cptEts > UBound(tablo, 1)) And Not trvEts
  If tablo(cptEts, 1) = lequel Then
  trvEts = True
  Else
  cptEts = cptEts + 1
  End If
  Wend

  If trvEts Then
  TrouveEts = cptEts
  Else
  TrouveEts = 0
  End If

End Function