preparer une liste d'étiquettes

'''Library IWshRuntimeLibrary
'''C:\WINDOWS\system32\wshom.ocx
'''Windows Script Host Object Model

'### Constante à adapter ###
Const DOSSIER As String = "C:\jeromear"
'###########################

Sub ListeEtiquettes()
Dim FSO As Object       'IWshRuntimeLibrary.FileSystemObject
Dim myFolder As Object  'IWshRuntimeLibrary.Folder
Dim FileItem As Object  'IWshRuntimeLibrary.File
Dim Classeurs()
Dim cpt&
Dim i&
Dim j&
Dim k&
Dim WB As Workbook
Dim S As Worksheet
Dim R As Range
Dim var1
Dim var2
Dim vide1 As Boolean
Dim vide2 As Boolean
Dim T()
Dim A$
Dim B$
If ThisWorkbook.Path = DOSSIER Then
  MsgBox "Ne pas mettre le classeur contenant le programme dans le dossier " & DOSSIER
  Exit Sub
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
Set myFolder = FSO.GetFolder(DOSSIER)
For Each FileItem In myFolder.Files
  If LCase(Right(FileItem.Name, 4)) = ".xls" Then
    k& = k& + 1
    ReDim Preserve Classeurs(1 To k&)
    Classeurs(k&) = FileItem.Name
  End If
Next FileItem
Set FileItem = Nothing
Set myFolder = Nothing
Set FSO = Nothing
If k& = 0 Then
  MsgBox "Aucun fichier .xls n'a été trouvé."
  Exit Sub
End If
Application.ScreenUpdating = False
For k& = 1 To UBound(Classeurs)
  B$ = Classeurs(k&)
  vide1 = False
  vide2 = False
  Set WB = GetObject(DOSSIER & "\" & Classeurs(k&))
  Set S = WB.Sheets(1)
  Set R = S.Range("a1:b" & S.[a65536].End(xlUp).Row & "")
  If R(2, 1) = "" Then
    vide1 = True
  Else
    var1 = R
  End If
  Set R = S.Range("e1:e" & S.[e65536].End(xlUp).Row & "")
  If R(1, 1) = "" Then
    vide2 = True
  Else
    var2 = R
  End If
  WB.Close False
  Set WB = Nothing
  If Not vide1 Then
  For i& = 1 To UBound(var1, 1)
    If Trim(var1(i&, 1)) <> "" And Trim(var1(i&, 2)) <> "" Then
      cpt& = cpt& + 1
      ReDim Preserve T(1 To 2, 1 To cpt&)
      T(1, cpt&) = "Me " & Trim(var1(i&, 1))
      T(2, cpt&) = Trim(var1(i&, 2))
      If Not vide2 Then
        For j& = 1 To UBound(var2, 1)
          A$ = Trim(var2(j&, 1))
          If A$ <> "" Then
            If UCase(Left(Trim(var1(i&, 1)), Len(A$))) = A$ Then
              T(1, cpt&) = "M " & Trim(var1(i&, 1))
            End If
          End If
        Next j&
      End If
    End If
  Next i&
  End If
Next k&
Set S = Sheets.Add(after:=Sheets(Sheets.Count))
S.Range(S.Cells(1, 1), S.Cells(UBound(T, 2), 2)) = WorksheetFunction.Transpose(T)
S.Columns.AutoFit
Erreur:
If Err <> 0 Then
  MsgBox "Erreur " & Err.Number & vbCrLf & Err.Description & vbCrLf & vbCrLf & _
    "L'erreur est survenue lors du chargement du classeur " & B$
End If
Application.ScreenUpdating = True
End Sub