Pb de boucle sur export tableau filtré (for each next)

[zebanx]

Bonjour à tous.

Pourriez-vous SVP m'aider dans la modification d'un code permettant d'exporter des range filtrés sur une feuille tampon ?
Cette export (temporaire) m'est utile pour un envoi de ce range à différentes personnes par outlook.

En gros, on exporte de la base contact temporairement sur la feuille "envoi" la partie du tableau qui concerne un contact (filtre sur colonne A dans la feuille "contacts") et un autre code permet de lancer outlook. Et ainsi de suite...

Partant d'un code de déconsolidation classique (et qui fonctionne)*, il y a un problème dans la boucle dès le deuxième passage.

Vous en remerciant par avance, bonne journée
zebanx

Sub Tri_filtres()
Dim Plage, Code, C As Range
Application.ScreenUpdating = False

With Sheets("contacts")
  If .FilterMode Then .ShowAllData
  Set Plage = .Range("A1:G" & .Cells(Rows.Count, "A").End(xlUp).Row)
  Set Code = .Range("A2:G" & .Cells(Rows.Count, "A").End(xlUp).Row)

  For Each C In Code
    Plage.AutoFilter Field:=1, Criteria1:=C
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("envoi").Range("a2:g1000").ClearContents
    Application.DisplayAlerts = True
    On Error GoTo 0
    Plage.SpecialCells(xlCellTypeVisible).Copy Sheets("envoi").[a1]
  Next
End With

Application.ScreenUpdating = True
End Sub

* code sur fil :
'https://www.excel-downloads.com/threads/création-automatique-donglet-sur-une-base-de-travail.20018027/#post-20131568

 

[Paf]

Bonjour,

Souci 1:
on veut filtrer Plage selon chaque cellule de Code (A2:Gxx) .
Itération 1 :la première cellule de Code(A2)= a001, filtrage OK
Itération 2 : la seconde cellule de Code(B2)= noma, filtrage NOK
il faudrait Set Code = .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)

Mais, souci 2:
Itération 1 :la première cellule de Code(A2)= a001, filtrage OK
Itération 2 : la seconde cellule de Code(A3)= a001, filtrage OK mais deuxième filtre avec le même critére
Itération 3 : la troisième cellule de Code(A4)= a001, filtrage OK mais troisième filtre avec le même critére
à moins que ce soit un jeu d'essai non représentatif du réel.

Souci 3:
le contact est en colonne E et non A ?

A+

 

[zebanx]

Bonjour Paf,

Merci.
Effectivement, ça fonctionne déjà mieux avec un export par code possible suite à ta remarque.

Les fichiers sont envoyés à une personne qui a 1 ou plusieurs contacts, la référence de l'envoi pour moi reste la colonne A. Après, à cette personne de contacter ses cibles (colonne E).

Il reste effectivement le problème de code "unique" pour chaque valeur filtrée, je vais essayer de regarder cela car là le code m'envoie à la même personne (colonne A) plusieurs fois le tableau par outlook.
Encore un peu de boulot en perspective -)

@+
zebanx

 

[Paf]

pour le code unique, on peut utiliser un dictionary:

Dim Dico, CC as Range
Set Dico = CreateObject("Scripting.Dictionary")
.../...
  For Each CC In Code
  Dico(CC.Value) = ""
  Next
  For Each Clé In Dico.keys
  Plage.AutoFilter Field:=1, Criteria1:=Clé
  Sheets("envoi").Range("a2:g1000").ClearContents
  Plage.SpecialCells(xlCellTypeVisible).Copy Sheets("envoi").[a1]
  Next
.../...

 

[zebanx]

Re-

Merci pour ta réponse et je viens de trouver, dans l'intervalle, une autre alternative fonctionnelle sans dictionnaire.

J'appelle une autre procédure ("mailto") pour l'envoi des différents tableaux mais ça fonctionne comme souhaité (un tableau par destinataire colonne A).

Toutefois, l'utilisation du dictionnaire pourrait être utile même si pour ce cas la plage n'est pas très grande (pas toute la base mais elle représente moins de 1000 lignes).
Et après essai ton code fonctionne parfaitement bien et est plus simple à utiliser même. Merci !

@+
zebanx

Sub Tri_filtres()
Dim Plage, Code, C As Range
Application.ScreenUpdating = False

With Sheets("contacts")
  If .FilterMode Then .ShowAllData
  Set Plage = .Range("A1:G" & .Cells(Rows.Count, "A").End(xlUp).Row)
  Set Code = .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)

derligne = Sheets("contacts").Cells(Rows.Count, 1).End(3).Row
n = 1

For Each C In Code
   '---copie si premier passage ou non doublon
   If n = 1 Then
   Sheets("envoi").Range("a2:g1000").ClearContents
   Plage.AutoFilter Field:=1, Criteria1:=C
   Plage.SpecialCells(xlCellTypeVisible).Copy Sheets("envoi").[a1]
   Call mailto '---autre procédure pour envoi tableau filtré par outlook
   End If
   '--- compare la valeur de la ligne du dessous pour incrémenter ou pas
   If Sheets("contacts").Cells(C.Row + 1, 1).Value = C Then
   n = n + 1
   Else
   n = 1
   End If
Next
End With

Application.ScreenUpdating = True
End Sub