Compléter une colonne

Le 14/09/2017 à 12:04

Bonjour

J’ai un fichier avec 3 colonnes pour la feuille 1 et 3 colonne pour la feuille 2

la feuille 1 comporte le numéro de police, une date et la génération (oui ou non)

la feuille 2 comporte le numéro de police, les mois et les année (2013 à 2020)

je veux compléter à l'aide d'une macro la colonne génération de la feuille 2

À partir de la feuille 1

je voudrais que pour chaque mois et chaque année si on a un seul non alors renvoyer non

renvoyer non à la même police au même mois et a la même année dans la feuille 2

si pour un même mois de la même année on a que des oui alors renvoyer oui

Par exemple

22/09/2017 non

06/11/2017 oui

05/11/2016 oui

06/11/2017 non

05/11/2016 oui

06/11/2016 oui

06/11/2016 oui

06/11/2016 oui

06/11/2016 oui

18/04/2016 oui

18/04/2016 oui

15/08/2017 oui

20/08/2017 oui

8/08/2017 oui

7/08/2017 oui

07/12/2017 non

2/08/2017 oui

Pour 09/2017 on va renvoyer non dans la feuille 2 pour le mois de septembre et l'année 2017

pour 11/2017 on va renvoyer non dans la feuille 2 pour le mois de novembre et l'année 2017

pour 04/2016 on va renvoyer oui dans la feuille 2 pour le mois d'avril et l'année 2016

pour 08/2017 on va renvoyer oui dans la feuille 2 pour le mois d'aout et l'année 2017

pour 12/2017 on va renvoyer non dans la feuille 2 pour le mois de décembre et l'année 2017

Voici la macro que j’ai essayé de faire

Sub Generation()

    Dim DernLigne As Long
    Dim i As Integer

    With ActiveSheet
        DernLigne = .Range("A" & .Rows.Count).End(xlUp).Row
    End With
    With Sheets("Feuil2")
        DernLigne1 = .Range("A" & .Rows.Count).End(xlUp).Row
    End With

    For L = 3 To DernLigne1
        'If Sheets("Feuil2").Cells(L, 10).Value <> "OUI" Then
            If Sheets("Feuil2").Cells(L, 2).Value = ActiveSheet.Cells(2, 1) Then

            k = Sheets("Feuil2").Cells(L, 4).Value

            If Sheets("Feuil2").Cells(L, 5).Value = "janvier" Then
                j = 1
            End If
            If Sheets("Feuil2").Cells(L, 5).Value = "février" Then
                j = 2
            End If
            If Sheets("Feuil2").Cells(L, 5).Value = "mars" Then
                j = 3
            End If
            If Sheets("Feuil2").Cells(L, 5).Value = "avril" Then
                j = 4
            End If
            If Sheets("Feuil2").Cells(L, 5).Value = "mai" Then
                j = 5
            End If
            If Sheets("Feuil2").Cells(L, 5).Value = "juin" Then
                j = 6
            End If
            If Sheets("Feuil2").Cells(L, 5).Value = "juillet" Then
                j = 7
            End If
            If Sheets("Feuil2").Cells(L, 5).Value = "août" Then
                j = 8
            End If
            If Sheets("Feuil2").Cells(L, 5).Value = "septembre" Then
                j = 9
            End If
            If Sheets("Feuil2").Cells(L, 5).Value = "octobre" Then
                j = 10
            End If
            If Sheets("Feuil2").Cells(L, 5).Value = "novembre" Then
                j = 11
            End If
            If Sheets("Feuil2").Cells(L, 5).Value = "décembre" Then
                j = 12
            End If

            For i = 2 To DernLigne
                If Year(Cells(i, 27).Value) = k And Month(Cells(i, 27).Value) = j Then
                    'a=
                End If
            Next i

            Sheets("Feuil2").Cells(L, 65).Value = a
            End If
        Next L

End Sub

ci joint un fichiers

merci pour votre aide

petite erreur c'est 2017 au lieu de 2016 pour celui la 05/11/2016 oui

8classeur2.xlsm (558.29 Ko)
Le 14/09/2017 à 12:13

Bonjour,

Est-ce-que tu veux une simple modification de ta macro ... ou une refonte ...

Le 14/09/2017 à 12:21

une refonte?

j'aimerais bien garder ma macro si possible

mercii bcp pour ton aide

Le 14/09/2017 à 13:03

Re,

Ta macro démarre débute avec

If Sheets("Feuil2").Cells(L, 2).Value = ActiveSheet.Cells(2, 1).Value Then

Or ... dans le fichier que tu as posté la Colonne B de la feuille 2 est vide ... et la Colonne A de la feuille 1 contien 'azv' ...

Merci de clarifier ....

Le 14/09/2017 à 13:08

oui désolé j'ai modifier

12classeur2.xlsm (560.30 Ko)
Le 14/09/2017 à 14:05

Re,

Désolé ... mais tu vas devoir m'expliquer ce que tu attends comme résultats de ta macro ...

Le 14/09/2017 à 14:13
James007 a écrit :

Re,

Désolé ... mais tu vas devoir m'expliquer ce que tu attends comme résultats de ta macro ...

Suis rassuré, James, pas le seul à ne pas comprendre le but

P.

Le 14/09/2017 à 15:46

j'ai essayé de reformuler ceux que ma macro devait faire

   'jai un classeur avec 2 feuilles
        ' sur la premiere feuille j'ai 3 colonnes
            'le numéro de police
            'une date
            'savoir si la generation est terminé ou pas
        'sur la deuxieme feuille j'ai egalement 3 colonnes
            'une colonne avec le numéro de la police
            'une colonne avec le mois
            'une colonne avec l'année
            'une colonne ou on effectue la macro
        'la macro consiste a savoir si par année et par mois la generation est terminé ou pas
        'a partir de la 1er feuille si pour chaque mois et pour chaque année on a que des oui mais un seul non alors la generation n'est pas terminé
        'par exemple , on a ces differentes date dans la feuille 1
        ' date      generation
        '22/09/2017 non
        '06/11/2017 non
        '05/11/2016 oui
        '06/11/2017 non
        '05/11/2016 oui
        '06/11/2016 oui
        '06/11/2016 oui
        '06/11/2016 oui
        '06/11/2016 oui
        '16/11/2017 oui
        '18/04/2016 oui
        '18/04/2016 non
        '27/08/2017 oui
        '07/12/2017 oui
        '08/12/2017 oui
        '12/03/2018 non
        '24/09/2017 non
        '20/12/2016 non

        'ca doit me renvoyer sur la feuille 2
        'sur la ligne de mars 2018 non
        'sur la ligne d'avril 2016 non (il ya 1 oui et 1 non mais c'est le non qui gagne)
        'sur la ligne d'aout 2017 oui
        'sur la ligne de septembre 2017 non
        'sur la ligne de novembre 2016 oui
        'sur la ligne de novembre 2017 non
        'sur la ligne de decembre 2016 non
        'sur la ligne de decembre 2017 oui
Le 14/09/2017 à 17:14

Re,

Désolé Aurelia ...

J'ai lu, relu et rerelu tes explications ...et je ne comprends pas ...

J'espère que quelqu'un d'autre pourra décrypter la chose ....

P.S. Si tu as la possibilité pour une seule ligne d'ajouter une formule qui permet de résoudre un cas ...cela pourrait aider ...

Le 18/09/2017 à 10:16

c'est pas grave merci quand meme

Le 18/09/2017 à 10:37

Bonjour,

J'ai peut être compris! Tu est toujours confronté à ton probleme?

Si oui je reformalise pour être sur d'avoir compris :

  • En fait le nom de la police on s'en moque
  • On extrait le mois et l'année de chaque date feuille 1, et si il y a un seul non qui correspond au mois de l'année, alors on met non en feuille 2

C'est ce que j'ai compris. Mais j'ai une question:

Pourquoi en feuille 2 tu as plusieurs fois les même dates? Aout 2014 apparaît au moins 5 fois par exemple.

Yann

Ps: je viens de voir que tu préférais une refonte, désolé, c'est pas trop mon truc les refontes. Je te ferai une macro add-hoc si j'ai bien cerné ton problème!

Le 18/09/2017 à 11:24

bonjour,

si j'ai bien compris.

on pourrait encore améliorer les performances si on peut aussi trier la feuil2.

Sub Generation()

    Dim DernLigne As Long
    Dim i As Integer, j As Integer, k As Integer, a As String, DerLigne1 As Long
    Dim wsw As Sheet, wsg As Sheet
    'pour améliorer les performances on prend une copie de feuil1 et on la trie sur police et date
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("tempcopy").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Sheets("feuil1").Copy after:=Sheets(Sheets.Count)
    Set wsw = Sheets(Sheets.Count)
    wsw.Name = "tempcopy"
    Set wsg = Sheets("feuil2")
    With wsw
        DernLigne = .Range("A" & .Rows.Count).End(xlUp).Row
        .Range("A1:AB" & DernLigne).Sort key1:=.Range("A1"), order1:=xlAscending, key2:=.Range("AA1"), order2:=xlAscending, Header:=xlYes
        DernLigne1 = wsg.Range("A" & .Rows.Count).End(xlUp).Row
        'génération
        For L = 3 To DernLigne1 '
            k = wsg.Cells(L, 4).Value
            If wsg.Cells(L, 5).Value = "janvier" Then
                j = 1
            ElseIf wsg.Cells(L, 5).Value = "février" Then
                j = 2
            ElseIf wsg.Cells(L, 5).Value = "mars" Then
                j = 3
            ElseIf wsg.Cells(L, 5).Value = "avril" Then
                j = 4
            ElseIf wsg.Cells(L, 5).Value = "mai" Then
                j = 5
            ElseIf wsg.Cells(L, 5).Value = "juin" Then
                j = 6
            ElseIf wsg.Cells(L, 5).Value = "juillet" Then
                j = 7
            ElseIf wsg.Cells(L, 5).Value = "août" Then
                j = 8
            ElseIf wsg.Cells(L, 5).Value = "septembre" Then
                j = 9
            ElseIf wsg.Cells(L, 5).Value = "octobre" Then
                j = 10
            ElseIf wsg.Cells(L, 5).Value = "novembre" Then
                j = 11
            ElseIf wsg.Cells(L, 5).Value = "décembre" Then
                j = 12
            End If
            'on recherche la police sur copie de feuil1
            Set re = .Range("A1:A" & DernLigne).Find(wsg.Cells(L, 1), lookat:=xlWhole)
            If Not re Is Nothing Then 'si police trouvée
                a = "non" 'par défaut la police n'est pas générée
                For i = re.Row To DernLigne
                    If .Cells(i, 1) <> wsg.Cells(L, 1) Then Exit For 'on arrête la boucle si police <> police recherchée
                    If Year(.Cells(i, 27)) >= k And Month(.Cells(i, 27)) > j Then Exit For 'on arrête la boucle si date est supérieure à la date cherchée
                    If Year(.Cells(i, 27).Value) = k And Month(.Cells(i, 27).Value) = j Then 'si année et mois identique
                        If .Cells(i, "AB") = "non" Then 'si non trouvé on arrête la boucle
                            a = "non": Exit For
                        Else
                            a = "oui" 'oui trouvé
                        End If
                    End If
                Next i
            Else
                a = "non" 'on a pas trouvé la police
            End If
            wsg.Cells(L, "BM").Value = a
        Next L
    End With
End Sub
Le 18/09/2017 à 11:42

oui c'est abdolument ca L-Yann

en faite il apparait plusieurs fois parce que j'ai plusieurs sinitres

Le 18/09/2017 à 11:50

Ok, et du coup si je met un "non" pour Aout 2014 par exemple, le "non" doit apparaître pour tous les Aout 2014?

La solution de H2SO4 te conviens ? (bonjour! )

Dans le cas ou c'est pas bon, je te pond une macro!

Le 18/09/2017 à 11:50
aurelia22 a écrit :

oui c'est abdolument ca L-Yann

en faite il apparait plusieurs fois parce que j'ai plusieurs sinitres

je n'ai donc rien compris

Le 18/09/2017 à 11:51

h2so4 je regarde ton code merci

oui un non pour tout les aout

voila ceux que j'ai fait mais ca marche pas

Sub Gene()

    Dim i As Integer

    With ActiveSheet
        DernLigne = .Range("A" & .Rows.Count).End(xlUp).Row
    End With
    With Sheets("CT")
        DernLigne1 = .Range("B" & .Rows.Count).End(xlUp).Row
    End With

    k = 0
    For L = 3 To DernLigne1
        If Sheets("CT").Cells(L, 2).Value = ActiveSheet.Cells(2, 1) Then
            k = L
            Exit For
        End If
    Next L

        Do While Sheets("CT").Cells(k, 2).Value = ActiveSheet.Cells(2, 1)
            If Sheets("CT").Cells(k, 20).Value <> "" Then
                a = "oui"
                For i = 2 To DernLigne
                    If Cells(i, 26).Value = Sheets("CT").Cells(k, 6).Value And Cells(i, 28).Value = "non" Then
                        a = "non"
                            Exit For
                    'Else
                        'a = "oui"
                    End If
                Next i
                Sheets("CT").Cells(k, 65).Value = a

            End If
            k = k + 1
        Loop
    'End If
End Sub
Le 18/09/2017 à 12:33

Re-Bonjour,

Tiens, un premier jet, ça m'a l'air de tourner correctement et de délivrer les résultats que tu veux! Testes de ton coté, tu me dit si ça tourne!

La procédure est un peu longue, je regarde comment optimiser ça et je reviens avec un code qui devrait être plus rapide, et commenté! 

Option Explicit

Function extractMois(ByVal entree As Date) As String

Dim TB As Variant

extractMois = CStr(entree)

If extractMois = "" Then Exit Function

If InStr(extractMois, "/") = 0 Then Exit Function
TB = Split(extractMois, "/")
extractMois = TB(1)

Select Case extractMois

    Case "01"
    extractMois = "janvier"
    Case "02"
    extractMois = "février"
    Case "03"
    extractMois = "mars"
    Case "04"
    extractMois = "avril"
    Case "05"
    extractMois = "mai"
    Case "06"
    extractMois = "juin"
    Case "07"
    extractMois = "juillet"
    Case "08"
    extractMois = "août"
    Case "09"
    extractMois = "septembre"
    Case "10"
    extractMois = "octobre"
    Case "11"
    extractMois = "novembre"
    Case "12"
    extractMois = "décembre"

End Select

End Function

Function extractAnnee(ByVal entree As Date) As String
Dim TB As Variant
extractAnnee = CStr(entree)
If InStr(extractAnnee, "/") = 0 Then Exit Function
TB = Split(extractAnnee, "/")
extractAnnee = TB(2)

End Function

Sub Generation()

Dim i As Long, j As Long
Dim LgSh1 As Long, LgSh2 As Long
Dim tabFeuille1 As Variant
Dim tabFeuille2 As Variant
Dim tabgeneration() As String

Application.ScreenUpdating = False
Application.EnableEvents = False

LgSh1 = ThisWorkbook.Sheets("feuil1").Range("AA65536").End(xlUp).Row
LgSh2 = ThisWorkbook.Sheets("feuil2").Range("D65536").End(xlUp).Row

ReDim tabgeneration(LgSh2, 0) As String

tabFeuille1 = ThisWorkbook.Sheets("feuil1").Range("AA1:AB" & LgSh1).Value
tabFeuille2 = ThisWorkbook.Sheets("feuil2").Range("D1:E" & LgSh2).Value

For i = 3 To LgSh2

    If tabgeneration(i-3, 0) = "" Then

        tabgeneration(i - 3, 0) = "oui"

        For j = 2 To LgSh1

            If extractMois(tabFeuille1(j, 1)) = tabFeuille2(i, 2) And extractAnnee(tabFeuille1(j, 1)) = tabFeuille2(i, 1) And tabFeuille1(j, 2) = "non" Then

            tabgeneration(i - 3, 0) = "non"
            Exit For

            End If

        Next j

        If i < LgSh2 Then
        For j = i + 1 To LgSh2

            If tabFeuille2(j, 1) = tabFeuille2(i, 1) And tabFeuille2(j, 2) = tabFeuille2(i, 2) Then tabgeneration(j - 3, 0) = tabgeneration(i - 3, 0)

        Next j
        End If

    End If

Next i

ThisWorkbook.Sheets("feuil2").Range("F3:F" & LgSh2).Value = tabgeneration

Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

Yann

Le 18/09/2017 à 12:56

Voilà la version 2 du code, Cette fois ci, il tourne en deux secondes, je suis pas sur de pouvoir faire mieux!

Tu as les commentaires pour adapter si besoin.

Option Explicit

Function extractMois(ByVal entree As Date) As String

Dim TB As Variant

extractMois = CStr(entree)

If extractMois = "" Then Exit Function

If InStr(extractMois, "/") = 0 Then Exit Function
TB = Split(extractMois, "/")
extractMois = TB(1)

Select Case extractMois

    Case "01"
    extractMois = "janvier"
    Case "02"
    extractMois = "février"
    Case "03"
    extractMois = "mars"
    Case "04"
    extractMois = "avril"
    Case "05"
    extractMois = "mai"
    Case "06"
    extractMois = "juin"
    Case "07"
    extractMois = "juillet"
    Case "08"
    extractMois = "août"
    Case "09"
    extractMois = "septembre"
    Case "10"
    extractMois = "octobre"
    Case "11"
    extractMois = "novembre"
    Case "12"
    extractMois = "décembre"

End Select

End Function

Function extractAnnee(ByVal entree As Date) As String
Dim TB As Variant
extractAnnee = CStr(entree)
If InStr(extractAnnee, "/") = 0 Then Exit Function
TB = Split(extractAnnee, "/")
extractAnnee = TB(2)

End Function

Sub Generation()

Dim i As Long, j As Long
Dim LgSh1 As Long, LgSh2 As Long
Dim tabFeuille1 As Variant
Dim tabFeuille2 As Variant
Dim tabgeneration() As String
Dim tabTransfoDates() As String

'On desactive rafraichissement d'ecran et evenements
Application.ScreenUpdating = False
Application.EnableEvents = False

'on recherche le nombre de data sur chaques feuilles
LgSh1 = ThisWorkbook.Sheets("feuil1").Range("AA65536").End(xlUp).Row
LgSh2 = ThisWorkbook.Sheets("feuil2").Range("D65536").End(xlUp).Row

'On redimmensionne les tableaux
'tableau de sortie
ReDim tabgeneration(LgSh2, 0) As String
'tableau de transformation des dates de la feuille 1
ReDim tabTransfoDates(LgSh1, 1) As String

'On récupère les données
tabFeuille1 = ThisWorkbook.Sheets("feuil1").Range("AA1:AB" & LgSh1).Value
tabFeuille2 = ThisWorkbook.Sheets("feuil2").Range("D1:E" & LgSh2).Value

'on transforme les dates de la feuille 1 pour en extraire le mois et l'année
For i = 2 To LgSh1

tabTransfoDates(i, 0) = extractMois(tabFeuille1(i, 1))
tabTransfoDates(i, 1) = extractAnnee(tabFeuille1(i, 1))

Next i

'on parcourt la totalité des données de la feuille 2
For i = 3 To LgSh2

    'Si on n'a pas encore traité cette date
    If tabgeneration(i - 3, 0) = "" Then

        'On place la valeur a oui
        tabgeneration(i - 3, 0) = "oui"

        'On parcourt les dates de la feuille 1 transformée)
        For j = 2 To LgSh1
            'Si les dates sont identique et que la génération est a non
            If tabTransfoDates(j, 0) = tabFeuille2(i, 2) And tabTransfoDates(j, 1) = tabFeuille2(i, 1) And tabFeuille1(j, 2) = "non" Then
            'on place le tableau de sortie a "non"
            tabgeneration(i - 3, 0) = "non"
            'On sort de la boucle
            Exit For

            End If

        Next j

        'pour toutes les dates qui suivent (sur la feuille 2)
        If i < LgSh2 Then
        For j = i + 1 To LgSh2
            'Si le mois et l'année sont identique lors je copie la valeur de la génération
            If tabFeuille2(j, 1) = tabFeuille2(i, 1) And tabFeuille2(j, 2) = tabFeuille2(i, 2) Then tabgeneration(j - 3, 0) = tabgeneration(i - 3, 0)

        Next j
        End If

    End If

Next i

'On colle le tableau
ThisWorkbook.Sheets("feuil2").Range("F3:F" & LgSh2).Value = tabgeneration

'On reactive evenements et rafraichissement d'écran
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

Dit moi si c'est bon pour toi!

Yann

Le 18/09/2017 à 13:30

ouahhh merci je regarde

Le 18/09/2017 à 14:09

Alors ça donne quoi?

Ps: Je commence le boulot dans une petite heure, après je pourrais plus trop aider!

Rechercher des sujets similaires à "completer colonne"