preparer une liste d'étiquettes

[jeromear]

Bonjour le forum,
Mon but est de créer un doc excel qui sera fusionné avec word pour éditer des étiquettes.
A partir de :
un dossier nommé "étiquettes" de 80 fichiers (2 fichiers joints pour démo)
un fichier nommé "liste étiquettes" (joint)

Je cherche à créer une macro dans le fichier "liste étiquettes" qui fasse :
-Dans chaque fichier du dossier "étiquettes", colonne A :
Ajouter "Me" devant chaque nom
Ajouter "M" devant chaque nom qui correspond à la colonne E
Colonnes A et B "non vides"
Copier la selection

Coller toutes les sélections dans le fichier "liste étiquettes" colonnes A et B les unes sous les autres.

Est ce que quelqu'un saurait faire cela?
Merci

Je précise que je commence tout juste à me former en vba.

Regarde la pièce jointe 4TEMPSETIQUETTES.xls

Regarde la pièce jointe AMIENSETIQUETTES.xls

Regarde la pièce jointe liste etiquettes.xls

 

[PMO2]

Re : preparer une liste d'étiquettes

Bonjour,

Un code compliqué si vous commencez à apprendre le VBA mais qui a le mérite de faire.

1) Copiez le code suivant dans un module standard

'''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

2) Dans C:\ mettez vos fichiers .xls dans un dossier nommé "jeromear" OU adaptez la constante DOSSIER cernée par des ###
3) Le classeur contenant le programme ne doit pas se trouver dans ce dossier.
4) Lancez la macro ListeEtiquettes et, si tout se passe bien, le résultat devrait s'afficher dans une nouvelle feuille.

Cordialement.

PMO
Patrick Morange

 

[jeromear]

Re : preparer une liste d'étiquettes

Bonsoir Patrick,
Tout d'abord, je vous remercie pour avoir pris le temps de programmer cette macro qui est tres importante pour moi.
Elle fonctionne mais j'ai 2 petits soucis lors du lancement :

- Le premier concerne une demande de mise à jour de liaisons pour chacun des fichiers du dossier (ils sont les résultats de liens avec d'autres classeurs, mais il est vrai que sur ceux que je joins pour le test j'ai volontairement "rompu" ces liaisons)

- le deuxieme : sur certains fichiers ex : GRENOBLE ETIQUETTES (joint) cela fait boguer la macro : "erreur d'execution 13" en jaune : For j& = 1 To UBound (var2, 1) (ligne n°110)
Pourtant ils semblent en tout point identiques aux autres

Merci beaucoup Patrick pour votre aide.
Regarde la pièce jointe GRENOBLE ETIQUETTES.xls

 

[PMO2]

Re : preparer une liste d'étiquettes

Bonjour,

Tenant compte de vos remarques voici, en pièce jointe, le code corrigé.

Cordialement.

PMO
Patrick Morange

 

[jeromear]

Re : preparer une liste d'étiquettes

Tout fonctionne !
Merci encore Patrick