XL 2013 Copier des lignes d'une feuille à une autre sur condition

Messan

XLDnaute Nouveau
Salut les boss,
S'il vous plait je souhaite votre aide sur un projet que je suis entrain de faire.
J'ai un tableau comportant des informations sur certains bénéficiaires. je voudrais que vous m'aider avec un code qui me permettra de copier automatiquement les lignes de la feuille 1 vers les feuilles suivantes:
copier automatiquement vers la feuille 0-2 ans toutes lignes dont la colonne F est comprise entre 0-2
copier automatiquement vers la feuille 3-5 ans toutes lignes dont la colonne F est comprise entre 3-5
copier automatiquement vers la feuille 6-8 ans toutes lignes dont la colonne F est comprise entre 6-8

et ainsi de suite.

NB: dans les autres feuilles sauf la feuille 1, déplacer toutes les lignes dont l'âge ne correspond plus vers la feuille correspondante c-à-d si sur la feuille 6-8 ans il y a une personne dont l'âge dépasse 8 doit être déplacer vers la feuille suivante (feuille 9-11 ans) et ainsi de suite.

Je joint le fichier en question.
 

Pièces jointes

  • Liste des bénéficiaires.xlsx
    14.8 KB · Affichages: 17

Robert

XLDnaute Barbatruc
Bonsoir le fil, bonsoir le forum,

En pièce jointe ton fichier modifié. Le code commence par supprimer tous les onglets sauf Feuil1, puis crée les onglets et y copie les données en fonction de l'âge en colonne F.
Le code :

VB:
Sub Macro1()
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (Incrément)
Dim PA As String 'déclare la variable PA (Plage Années)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim TD() As Variant 'déclare la variable TD (Tableau des Dates)
Dim TMP As String 'déclare la variabe TMP (TeMPoraire)

Application.ScreenUpdating = False 'masque les raffraîchissements d'écran
Set OS = Worksheets("Feuil1") 'définit l'onglet OS
Application.DisplayAlerts = False 'masque les messages d'Excel
For Each OD In Sheets 'boucle sur tous les onglets OD du classeur
    If OD.Name <> "Feuil1" Then OD.Delete 'si le nom de l'onglet de la boucle n'est pas "Feui1", supprime l'onglet
Next OD 'prochain onglet de la boucle
Application.DisplayAlerts = True 'affiche les messages d'Excel
TV = OS.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    PA = (TV(I, 6) \ 3) * 3 & "-" & (TV(I, 6) \ 3) * 3 + 2 & " ans" 'définit la plage des années PA relative à la donnée ligne I colonne 6 de TV
    On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
    Set OD = Worksheets(PA) 'définit l'onglet OD de la plage des années (génère une erreur si cet onglet n'existe pas)
    If Err <> 0 Then 'condition : si une erreur a été générée
        Err.Clear 'supprime l'erreur
        Worksheets.Add 'ajoute un onglet vierge
        Set OD = ActiveSheet 'définit l'onglet destination OD
        OD.Name = PA 'renomme l'onlget OD
    End If 'fin de la condition
    On Error GoTo 0 'annule la gestion des erreurs
    OD.Range("A1").Resize(1, 11).Value = Application.Index(TV, 1) 'renvoie la ligne de titres du tableau des valeurs TV dans la première ligne de l'onglet OD
    Set DEST = OD.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0) 'définit la cellue de destination DEST
    DEST.Resize(1, 11).Value = Application.Index(TV, I) 'renvoie la ligne I du tableau des valeurs TV dans DEST
    OD.Columns(6).NumberFormat = "0" 'format colonne 6
    OD.Columns(8).NumberFormat = "0" 'format colonne 8
    OD.Columns("A:K").AutoFit 'largeur des colonnes
    OD.Columns(4).HorizontalAlignment = xlCenter 'colonne 4 centrée
    OD.Columns(6).HorizontalAlignment = xlCenter 'colonne 6 centrée
    OD.Columns(8).HorizontalAlignment = xlCenter 'colonne 8 centrée
Next I 'prochaine ligne de la boucle

'tri alphabétique des onglets en pasant par le tableau des dates TD
ReDim TD(1 To Sheets.Count - 1) 'redimensionne le tableau des dates TD
J = 1 'initialise la variable J
For I = 1 To Sheets.Count 'boucle 1 : sur tous les onglets I du classeur
    If Sheets(I).Name <> "Feuil1" Then TD(J) = Sheets(I).Name: J = J + 1 'si le nom de l'ponglet I n'est pas "Feuil" définit la variable TD(J), incrémente J
Next I 'prochain onglet de la boucle
For I = 1 To UBound(TD) 'boucle 1 : sur toutes les date I du tabeau des dates TD
    For J = 1 To UBound(TD) 'boucle 2 : sur toutes les date J du tabeau des dates TD
        If I <> J Then 'condition : si I est différente de J
            If CInt(Split(TD(I), "-")(0)) < CInt(Split(TD(J), "-")(0)) Then 'condition 2 : si le premier chiffre avant le tiret a date TD(I)est supérieur au premier chiffre avant le tiret de la date TD(J)
                TMP = TD(J): TD(J) = TD(I): TD(I) = TMP 'définit la temporaire TMP, TD(J) devient TD(I),TD(I) devient la temporaire TMP (soit TMP(J)), inversion de l'ordre des dates
            End If 'fin de la condition 2
        End If 'fin de la condition 1
    Next J 'prochaine date de la boucle 2
Next I 'prochaine date de la boucle 1
For I = 1 To UBound(TD) 'boucle sur tous les dates I du tableau des dates TD
    Worksheets(TD(I)).Move Before:=Sheets(I) 'déplace l'onglet de la date I en position I
Next I 'prochaine date de la boucle
OS.Move Before:=Sheets(1) 'place l'onglet OS en première position

Application.ScreenUpdating = True 'affiche les raffraîchissements d'écran
OS.Activate 'active l'onglet source OS
End Sub
Le fichier :
 

Pièces jointes

  • Messan_ED_v01.xlsm
    44.2 KB · Affichages: 6
Dernière édition:

Messan

XLDnaute Nouveau
Bonsoir le fil, bonsoir le forum,

En pièce jointe ton fichier modifié. Le code commence par supprimer tous les onglets sauf Feuil1, puis crée les onglets et y copie les données en fonction de l'âge en colonne F.
Le code :

VB:
Sub Macro1()
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (Incrément)
Dim PA As String 'déclare la variable PA (Plage Années)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim TD() As Variant 'déclare la variable TD (Tableau des Dates)
Dim TMP As String 'déclare la variabe TMP (TeMPoraire)

Application.ScreenUpdating = False 'masque les raffraîchissements d'écran
Set OS = Worksheets("Feuil1") 'définit l'onglet OS
Application.DisplayAlerts = False 'masque les messages d'Excel
For Each OD In Sheets 'boucle sur tous les onglets OD du classeur
    If OD.Name <> "Feuil1" Then OD.Delete 'si le nom de l'onglet de la boucle n'est pas "Feui1", supprime l'onglet
Next OD 'prochain onglet de la boucle
Application.DisplayAlerts = True 'affiche les messages d'Excel
TV = OS.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    PA = (TV(I, 6) \ 3) * 3 & "-" & (TV(I, 6) \ 3) * 3 + 2 & " ans" 'définit la plage des années PA relative à la donnée ligne I colonne 6 de TV
    On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
    Set OD = Worksheets(PA) 'définit l'onglet OD de la plage des années (génère une erreur si cet onglet n'existe pas)
    If Err <> 0 Then 'condition : si une erreur a été générée
        Err.Clear 'supprime l'erreur
        Worksheets.Add 'ajoute un onglet vierge
        Set OD = ActiveSheet 'définit l'onglet destination OD
        OD.Name = PA 'renomme l'onlget OD
    End If 'fin de la condition
    On Error GoTo 0 'annule la gestion des erreurs
    OD.Range("A1").Resize(1, 11).Value = Application.Index(TV, 1) 'renvoie la ligne de titres du tableau des valeurs TV dans la première ligne de l'onglet OD
    Set DEST = OD.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0) 'définit la cellue de destination DEST
    DEST.Resize(1, 11).Value = Application.Index(TV, I) 'renvoie la ligne I du tableau des valeurs TV dans DEST
    OD.Columns(6).NumberFormat = "0" 'format colonne 6
    OD.Columns(8).NumberFormat = "0" 'format colonne 8
    OD.Columns("A:K").AutoFit 'largeur des colonnes
    OD.Columns(4).HorizontalAlignment = xlCenter 'colonne 4 centrée
    OD.Columns(6).HorizontalAlignment = xlCenter 'colonne 6 centrée
    OD.Columns(8).HorizontalAlignment = xlCenter 'colonne 8 centrée
Next I 'prochaine ligne de la boucle

'tri alphabétique des onglets en pasant par le tableau des dates TD
ReDim TD(1 To Sheets.Count - 1) 'redimensionne le tableau des dates TD
J = 1 'initialise la variable J
For I = 1 To Sheets.Count 'boucle 1 : sur tous les onglets I du classeur
    If Sheets(I).Name <> "Feuil1" Then TD(J) = Sheets(I).Name: J = J + 1 'si le nom de l'ponglet I n'est pas "Feuil" définit la variable TD(J), incrémente J
Next I 'prochain onglet de la boucle
For I = 1 To UBound(TD) 'boucle 1 : sur toutes les date I du tabeau des dates TD
    For J = 1 To UBound(TD) 'boucle 2 : sur toutes les date J du tabeau des dates TD
        If I <> J Then 'condition : si I est différente de J
            If CInt(Split(TD(I), "-")(0)) < CInt(Split(TD(J), "-")(0)) Then 'condition 2 : si le premier chiffre avant le tiret a date TD(I)est supérieur au premier chiffre avant le tiret de la date TD(J)
                TMP = TD(J): TD(J) = TD(I): TD(I) = TMP 'définit la temporaire TMP, TD(J) devient TD(I),TD(I) devient la temporaire TMP (soit TMP(J)), inversion de l'ordre des dates
            End If 'fin de la condition 2
        End If 'fin de la condition 1
    Next J 'prochaine date de la boucle 2
Next I 'prochaine date de la boucle 1
For I = 1 To UBound(TD) 'boucle sur tous les dates I du tableau des dates TD
    Worksheets(TD(I)).Move Before:=Sheets(I) 'déplace l'onglet de la date I en position I
Next I 'prochaine date de la boucle
OS.Move Before:=Sheets(1) 'place l'onglet OS en première position

Application.ScreenUpdating = True 'affiche les raffraîchissements d'écran
OS.Activate 'active l'onglet source OS
End Sub
Le fichier :
Tellement merci pour l'aide c'est vraiment ce que je voulais. Un très bon travail.
S'il vous plait pourriez vous m'aider à réadapter le code de façon à pouvoir insérer des colonnes au besoins dans la feuille 1 soit au milieu ou à la fin du tableau? car à l'essaie les feuilles copiées affichent erreurs (#N/A).

Par contre la colonne "A" sur les feuilles copiées doit suivre la numérotation automatique de 1 au nombre de ligne ajoutée (1, 2, 3, .... et non le numéro d'ordre de la feuille A1)


merci d'avance
 
Dernière édition:

Robert

XLDnaute Barbatruc
Re,

Il me faut un modèle pour adapter le code et il faut que ce soit définitif car je ne peux pas adapter comme ça le code à convenance... En pièce jointe la version 2 avec la numérotation des lignes...
 

Pièces jointes

  • Messan_ED_v02.xlsm
    44.5 KB · Affichages: 5

Messan

XLDnaute Nouveau
Re,

Il me faut un modèle pour adapter le code et il faut que ce soit définitif car je ne peux pas adapter comme ça le code à convenance... En pièce jointe la version 2 avec la numérotation des lignes...
Vous avez raison et je continue par vous remercier et pourquoi pas tout le forum.
S'il vous plait voici en définitif mon fichier à coder. S'il vous plait tenez compte du tableau c'est à dire de A1 à A1001 et de A à AJ).
Merci
 

Pièces jointes

  • Liste des bénéficiaires 2.xlsx
    201 KB · Affichages: 3

Robert

XLDnaute Barbatruc
Re,

Je ne comprends pas pourquoi beaucoup de demandeurs envoient un fichier qui ne correspond pas à la réalité. Ce n'est que perte de temps et comme chantait l'autre : ça m'énerve...
En pièce jointe la version 3. Clique sur le bouton Extraire...
 

Pièces jointes

  • Messan_ED_v03.xlsm
    229.4 KB · Affichages: 10

Messan

XLDnaute Nouveau
Re,

Je ne comprends pas pourquoi beaucoup de demandeurs envoient un fichier qui ne correspond pas à la réalité. Ce n'est que perte de temps et comme chantait l'autre : ça m'énerve...
En pièce jointe la version 3. Clique sur le bouton Extraire...
Chef mes sincères remerciements pour votre aide. Que Dieu vous bénisse.

Si seulement je pourrais être formé comme vous !
 

Messan

XLDnaute Nouveau
Re,

Je ne comprends pas pourquoi beaucoup de demandeurs envoient un fichier qui ne correspond pas à la réalité. Ce n'est que perte de temps et comme chantait l'autre : ça m'énerve...
En pièce jointe la version 3. Clique sur le bouton Extraire...
Bonjour grand chef,
Vous m'avez beaucoup aider et je ne saurai vraiment commet vous remercier.
En effet dans l'exécution j'ai eu un tout petit souci, raison pour laquelle je suis revenu à vous, mon seul moyen.

J'aimerais que vous m'indiquez comment corriger cette partie du code. Il s'agit de changer la feuille 15-17 ans à 15-18 ans et la feuille 18-20 ans à 18-22 ans.
Et si vous le permettez ranger toutes les âges supérieures à 22 ans dans une seule feuille.
 

Pièces jointes

  • Messan_ED_v03.xlsm
    229.4 KB · Affichages: 2

Robert

XLDnaute Barbatruc
Re,

On ne peut pas avoir de 15 à 18 et de 18 à 22. J'ai fait de 15 à 18 et de 19 à 22 et une dernière pour tout ce qui est supérieur à 22...
La version 4 en pièce jointe
 

Pièces jointes

  • Messan_ED_v04.xlsm
    264 KB · Affichages: 8

Discussions similaires

Haut Bas