Discussion :

[Nonouf]

Bonjour à tous,


Utilisateur plutôt débutant d'Excel VBA, je pianote beaucoup sur ce logiciel par plaisir.
Je consulte depuis longtemps ce forum et je viens de m'inscrire car je ne trouve pas de réponse à mon problème.

Voici mon problème :

J'ai un premier onglet que j'appelle "à intégrer" dans lequel se trouve un tableau de 8 colonnes (de A à H).
Ce tableau peut avoir jusqu'à une trentaine de ligne.
Il s'agit d'une feuille dans laquelle arrivent des données issues d'un fichier txt.

Dans mon deuxième onglet que j'appelle "Data" , j'ai le même tableau avec d'autres données et une colonne supplémentaire en I qui contient du numérique.

Ce que je cherche à faire via VBA :

Intégrer les lignes de l'onglet "à intégrer" dans l'onglet "Data" en m'assurant avant qu'il n'existe pas déjà dans l'onglet "Data" une ligne comportant les mêmes valeurs en colonnes B, C, E, G et H.
Si une ligne existe déjà avec les mêmes valeurs dans ces colonnes, je dois alors incrémenter la colonne I (valeur numérique) de cette ligne de +1.
Si aucune ligne ne correspond, je dois alors ajouter cette ligne dans l'onglet "Data" avec la valeur 1 en colonne I.


Voià voilà, j'espère que ce problème donnera du plaisir aux plus expérimentés


Merci à vous.
Nonouf

[Invité]

Bonsoir,
regarde ça : http://www.developpez.net/forums/d13...-via-userform/

[eric4459]

Bonsoir
Essayes ceci, j'ai écrit cela en vitesse pour les colonnes B et C, tu devras adapter ensuite.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Sub A_INTEGRER()
 
 
Dim Base As Worksheet
Dim data As Worksheet
Dim BL As Range
Dim ACVAL As Range
Dim i As Integer
Set Base = ThisWorkbook.Sheets("à intégrer")
Set data = ThisWorkbook.Sheets("Data")
Set BL = Base.Range(" B1")
BL = BL.Offset(0)
Set ACVAL = data.Range("B1")
ACVAL = ACVAL.Offset(0)
 
For i = 0 To 30
If BL.Offset(i, 0) & BL.Offset(i, 1) = ACVAL.Offset(i, 0) & ACVAL.Offset(i, 1) Then
ACVAL.Offset(i, 8) = ACVAL.Offset(i, 8) + 1
Else
ACVAL.Offset(i + 1, 0) = BL.Offset(i, 0)
ACVAL.Offset(i + 1, 1) = BL.Offset(i, 1)
End If
i = i + 1
Next i
 
End Sub

Eric

[Marc-L]

Bonsoir !

Nonouf, j'ai une manière efficiente et particulière de le faire (peu de lignes de code),
déjà exposée avec succès sur un forum étranger mais pas encore sur celui-ci !
C'est en fait une variante de l'utilisation d'un objet connu mais via une propriété non documentée officiellement,
du moins à l'époque. J'attendais un cas concret pour poster une contribution …

Cependant j'aurais besoin de connaitre la version d'Excel - devant pourtant être indiquée dans le titre de la discussion
(conformément aux règles du forum !) - et si c'est bien sous Windows
(pour Mac c'est mort ! Quoique j'ai sous le coude une autre méthode un peu mois rapide mais convenable …)
ainsi qu'un classeur xlsx (sans code) comportant les feuilles sources et une feuille résultat désiré.

[Nonouf]

Bonjour,

Merci pour ces premières contributions

A rdurupt :
Je crois que je n'ai pas le niveau pour adapter ton code

A Eric :
C'est un peu plus à ma portée, je vais faire des essais, ca m'a donné des idées.

A Marc :
Ca m'intérèsse !

Je vous joins un fichier exemple comme demandé.
Dans l'onglet résultat, j'ai mis les changements en rouge.
A la fin du traitement, la feuille A INTEGRER est de nouveau vierge.
Je suis sous Win 7 et Excel 2010.


Merci à vous.
Nonouf

[Invité]

la solution que tu cherche est dans les exemples!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
Sub test()
Dim Init As Boolean
Dim DerL As Long
'***************************************************
'Vérification de l'existant avant import CSV
Init = False
Set MyRange = Sheets("Feuil1").UsedRange
Debug.Print "********************"
Debug.Print "Sur la ligne"
For L = 1 To MyRange.Rows.Count
    Debug.Print Highlander(Init, MyRange.Range(MyRange(L, 1), MyRange(L, MyRange.Columns.Count)))
Next
 
Set MyRange = Sheets("Feuil2").UsedRange
Debug.Print "********************"
Debug.Print "Sur la ligne"
For L = 1 To MyRange.Rows.Count
   If Highlander(Init, MyRange.Range(MyRange(L, 1), MyRange(L, MyRange.Columns.Count))) = False Then
  DerL = Sheets("Feuil1").Cells(Sheets("Feuil1").Cells.Rows.Count, 1).End(xlUp).Row + 1
    MyRange.Range(MyRange(L, 1), MyRange(L, MyRange.Columns.Count)).Copy Sheets("Feuil1").Cells(DerL, 1)
   End If
Next
 
End Sub
 
Function Highlander(Init As Boolean, ParamArray Plage()) As Boolean
'..................................................
'La méthode Highlander, il ne peut en rester qu'un.
'Retourne True si doublon.
'..................................................
 
Static CollectDoublon As Collection
Dim T As String
Dim PlageIndex As Long
Dim myPlage As Range
Dim Col As Integer
Dim Tableau
If Init = False Then
Init = True
   Set CollectDoublon = Nothing
   Set CollectDoublon = New Collection
End If
 
 
T = "T"
For PlageIndex = 0 To UBound(Plage)
If TypeName(Plage(PlageIndex)) = "Range" Then
       Set myPlage = Plage(PlageIndex)
 
       For Col = 1 To myPlage.Columns.Count
        T = T & "_" & Trim("" & myPlage(1, Col))
       Next
    Else
        If TypeName(Plage(PlageIndex)) = "Variant()" Then
           Tableau = Plage(PlageIndex)
        Else
            If TypeName(Plage(PlageIndex)) Like "*()" Then
                Tableau = Plage(PlageIndex)
            Else
                Tableau = Split(Plage(PlageIndex) & ";", ";")
            End If
        End If
         For Col = 0 To UBound(Tableau)
           If Trim("" & Tableau(Col)) <> "" Then T = T & "_" & Trim("" & Tableau(Col))
         Next
    End If
Next
On Error Resume Next
CollectDoublon.Add T, T
If Err <> 0 Then Highlander = True
On Error GoTo 0
End Function

la méthode Highlander tu n'y touche pas tu l'utilise c'est tout!

[vinc_bilb]

Bonjour,

Moins élégant mais très efficace selon moi:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

ResRng.RemoveDuplicates Columns:=Array(1,2, .....), Header:=xlYes

Ca fonctionne exactement comme la fonction excel du même nom
Bonne journée

[Marc-L]

L'astuce évoquée serait un peu too much dans ce cas car une clef sur l'immatriculation - unique donc - est suffisante !

Par contre dans la feuille A INTEGRER il n'y a pas de corrélation pour la première ligne (Nissan) avec la feuille DATA,
juste une erreur dans ce fichier exemple fait à la va-vite ?

Sinon en utilisant les fonctions de feuilles de calculs, le code serait plus simple que le post #6 …
La méthode RemoveDuplicates ne convient pas car il ne s'agit pas d'une simple copie !

[Nonouf]

Par contre dans la feuille A INTEGRER il n'y a pas de corrélation pour la première ligne (Nissan) avec la feuille DATA,
juste une erreur dans ce fichier exemple fait à la va-vite ?

Non, c'est normal, cette ligne est identique à la ligne NISSAN de la feuille DATA sur les colonnes B,C,E,G et H donc j'actualise la ligne NISSAN de la feuille DATA sur les colonnes A (date en provenance de la feuille A INTEGRER) et I (+1).

En gros, dans mon exemple que j'ai imaginé pour l'occasion, je gère une liste de types de pannes (colonne G), sur des véhicules assurés (N°contrat en colonne H).
Les nouvelles pannes arrivent au format texte, je les importe sur la feuille A INTEGRER.
La macro devra intégrer ces nouvelles pannes dans la feuille DATA.
Si la même panne (col G) se répète sur le même véhicule (même marque (col B), même modèle (col C), même année (col E), même contrat (col H)) alors je mets seulement à jour la date et j'augmente la colonne I de +1.
Si la nouvelle panne est sur un véhicule dejà connu mais d'un type de panne différent, j'ajoute une ligne.
Si la nouvelle panne est sur un véhicule inconnu, j'ajoute une ligne.
Le but est surtout de détecter les pannes qui se répètent sur le même véhicule.
Proprio et Immat sont des données qui peuvent varier tout au long de la vie du véhicule.

C'est vrai que c'est un peu tordu mon truc

D'avance merci pour vos lumières.
Nonouf

[eric4459]

Bonjour Nonouf
Je me suis lancé un peu vite hier et le code que je t'ai envoyé peut-être à la rigueur une base mais pas la solution à ton problème.
J'y repensé aujourd'hui et travaillé sur le code (mais j'y ai passé du bon temps, le VBA on y devient accro ).
Je suppose que les experts et les puristes y trouveront des défauts mais ce code semble fonctionner, à toi d'essayer

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
Sub A_INTEGRER()
 
Dim Base As Worksheet
Dim data As Worksheet
Dim BL As Range
Dim ACVAL As Range
Dim i As Integer
Dim j As Integer
Set Base = ThisWorkbook.Sheets("A INTEGRER")
Set data = ThisWorkbook.Sheets("DATA")
Set BL = Base.Range(" A1")
BL = BL.Offset(0)
Set ACVAL = data.Range("A1")
ACVAL = ACVAL.Offset(0)
i = 0
j = 0
data.Select
 
For i = 0 To 29 'Ici on va vérifier les 30 ligne de l'onglet "A INTEGRER" (meme si elles sont vide) A ADAPTER
 
Do While ACVAL.Offset(j, 0) <> ""  'on vérifie tous les lignes de l'onglet "DATA"
If BL.Offset(i, 1) = ACVAL.Offset(j, 1) And BL.Offset(i, 2) = ACVAL.Offset(j, 2) And BL.Offset(i, 4) = ACVAL.Offset(j, 4) And BL.Offset(i, 6) = ACVAL.Offset(j, 6) And BL.Offset(i, 7) = ACVAL.Offset(j, 7) Then
ACVAL.Offset(j, 8) = ACVAL.Offset(j, 8) + 1 'Si les données des colonnes B, C, E, G et H sont identiques on incrémente la colonne I de la feuille "DATA"
ACVAL.Offset(j, 0) = BL.Offset(i, 0) 'ici on actualise la date de la ligne identique à celle dans l'onglet"A INTEGRER"
BL.Offset(i, 8) = 1 'Si les données des colonnes B, C, E, G et H sont identiques on marquela la ligne de la feuille "A INTEGRER"
'on pourra ensuite selectionner et supprimer ces lignes et ne copier dans l'onglet "DATA" que celles qui ont des diffèrences
i = i + 1
j = 0
Else
i = i
j = j + 1
End If
Loop
j = 0
Next i
i = 0
j = 0
 
Base.Select
 
Do While BL.Offset(i, 0) <> ""
If BL.Offset(i, 8) = 1 Then
BL.Offset(i, 0).Select               'Ici on selectionne les lignes marquées et on les supprime
Range(Selection, Selection.End(xlToRight)).Select
Selection.Delete
i = 0
Else
i = i + 1
End If
 
Loop
i = 0
 
BL.Offset(i, 0).Select
Range(Selection, Selection.End(xlToRight)).Select 'Ici on copie les lignes différentes
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
 
data.Select
Range("A65000").End(xlUp).Offset(1).Select 'recherche la première cellule vide pour y coller les nouvelles lignes
ActiveSheet.Paste
 
Do While ACVAL.Offset(j, 0) <> ""
If ACVAL.Offset(j, 8) = "" Then     'ici met la valeur 1 en colonne I pour les nouvelles lignes
ACVAL.Offset(j, 8) = 1
End If
j = j + 1
Loop
 
Base.Select
BL.Offset(i, 0).Select
Range(Selection, Selection.End(xlToRight)).Select   'Ici on vide la feuille "A INTEGRER"
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete
Range("A1").Select
 
End Sub

Voici le fichier avec le code en pièce jointe (après test donc feuille "A INTEGRER" vide et feuille "DATA" mise à jour)

exemple.xlsm

En espérant avoir pu t'aider
Eric

[Marc-L]

Non, c'est normal, cette ligne est identique à la ligne NISSAN de la feuille DATA sur les colonnes B,C,E,G et H donc j'actualise la ligne NISSAN de la feuille DATA sur les colonnes A (date en provenance de la feuille A INTEGRER) et I (+1).

Je reformule : deux immatriculations pour un même véhicule, est-ce normal ?

Car avec une immatriculation unique (logique), le code est tout simple et tient en à peine plus de 20 lignes de code …

Voici une démonstration simple et efficace calée sur le numéro de contrat

utilisant les fonctions de feuilles de calculs EQUIV (Match en VBA) et INDEX :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Sub Demo()
    Dim Rg As Range
 
    With Feuil1.Cells(1).CurrentRegion
        If .Columns.Count < 8 Or Feuil2.Cells(1).CurrentRegion.Columns.Count < 9 Then Beep: Exit Sub
        Application.ScreenUpdating = False
 
        For Each Rg In .Rows
            With Feuil2.Cells(1).CurrentRegion.Rows
                V = Application.Match(Rg.Cells(8).Value, Application.Index(.Cells, , 8), 0)
 
                If IsError(V) Then
                    With .Item(.Count)(2):  Rg.Copy .Cells(1):  .Cells(9).Value = 1:  End With
                Else
                    With .Item(V)
                                .Cells(1).Value = Rg.Cells(1).Value
                        With .Cells(9):  .Value = .Value + 1:  End With
                    End With
                End If
            End With
        Next
 
        .Clear
    End With
End Sub

Je regarderais demain pour gérer les colonnes B, C, E, G & H comme clef (j'avais mal lu) …

[Marc-L]

Une clef sur les colonnes G & H est suffisante pour le fichier exemple :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
Sub DemoTypeEtContrat()
    Dim Rg As Range
 
    With Feuil2.Cells(1).CurrentRegion
        If .Columns.Count < 8 Then Beep: Exit Sub
                      C& = .Rows.Count:  ReDim TK$(1 To C)
        For R& = 1 To C
            TK(R) = UCase$(.Cells(R, 7).Value & "¤" & .Cells(R, 8).Value)
        Next
    End With
 
    With Feuil1.Cells(1).CurrentRegion
        If .Columns.Count < 8 Then Beep: Exit Sub
        Application.ScreenUpdating = False
 
        For Each Rg In .Rows
            K$ = UCase$(Rg.Cells(7).Value & "¤" & Rg.Cells(8).Value)
             V = Application.Match(K, TK, 0)
 
            With Feuil2
                If IsError(V) Then
                    C = C + 1:  ReDim Preserve TK(1 To C):  TK(C) = K
                    Rg.Copy .Cells(C, 1):      .Cells(C, 9).Value = 1
                Else
                           .Cells(V, 1).Value = Rg.Cells(1).Value
                    With .Cells(V, 9): .Value = .Value + 1:  End With
                End If
            End With
        Next
 
        .Clear
    End With
End Sub

_________________________________________________________________________________________________

Merci de cliquer sur pour chaque message ayant aidé puis sur pour clore cette discussion …

[Nonouf]

Je reformule : deux immatriculations pour un même véhicule, est-ce normal ?

Car avec une immatriculation unique (logique), le code est tout simple et tient en à peine plus de 20 lignes de code …

Bonjour,

Oui Marc, c'est normal, le véhicule peut avoir changer de proprio et d'immatriculation.
J'ai pas trop le temps de bosser sur mon problème en ce moment, je crois que j'avais un début de solution en posant une formule dans une colonne cachée au bout de mon tableau. Une formule qui concatène les colonnes qui m'intéressent. Ceci dans les deux feuilles. Ensuite il faut que j'écrive le code qui comparera cette colonne.

Je m'y remets dès que j'ai du temps
Je ne manquerai pas de clôturer le sujet.

Bon week à tous.
Nonouf

[Marc-L]

Merci de tester au moins le code du post #12 car il va bien avec ton fichier exemple,
la concaténation s'effectuant dans une variable tableau …

[Nonouf]

Bonjour Marc,

En effet, il y a un début de solution à mon problème.
Mais j'ai vraiment besoin que le contrôle se fasse sur les 5 colonnes.
Seulement si les cinq colonnes sont identiques on incrémente de +1 et on met la date à jour

Dans mon fichier exemple, si je modifie l'année de la NISSAN JUKE dans la feuille A INTEGRER , ton code incrémentera quand même de +1.

Comme mon niveau ne me permet pas de comprendre ton code (pas complètement) je n'arrive pas à l'adapter.

Mais j'y retourne. Suis têtu.

Merci encore.

[Marc-L]

Voici la démonstration évoquée lors de ma première intervention :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
Sub DemoDictHashVal()
    Dim Dict As Object, Rg As Range
 
    With Feuil2.Cells(1).CurrentRegion.Columns
        If .Count < 8 Or Feuil1.Cells(1).CurrentRegion.Columns.Count < 8 Then Beep: Exit Sub
        RC& = .Rows.Count:  VA = .Value:  Set Dict = CreateObject("Scripting.Dictionary")
    End With
 
    With Dict
        For R& = 2 To RC
            .Item(.HashVal(Join(Array(VA(R, 2), VA(R, 3), VA(R, 5), VA(R, 7), VA(R, 8)), "¤"))) = R
        Next
    End With
 
    Erase VA:  Application.ScreenUpdating = False
 
    With Feuil1.Cells(1).CurrentRegion
        For Each Rg In .Rows
            With Rg
                K = Dict.HashVal(Join(Array(.Cells(2).Value, .Cells(3).Value, .Cells(5).Value, _
                                            .Cells(7).Value, .Cells(8).Value), "¤"))
            End With
 
            With Feuil2
                If Dict.Exists(K) Then
                    R = Dict.Item(K):   .Cells(R, 1).Value = Rg.Cells(1).Value
                    With .Cells(R, 9):  .Value = .Value + 1:  End With
                Else
                    RC = RC + 1: Dict.Add K, RC: Rg.Copy .Cells(RC, 1): .Cells(RC, 9).Value = 1
                End If
            End With
        Next
 
        Dict.RemoveAll:  Set Dict = Nothing:  .Clear
    End With
End Sub

Voilà tu as les deux méthodes :

la classique du post #12 (y compléter juste la concaténation) et ici celle via l'objet Dictionary (uniquement sur Windows) …

_________________________________________________________________________________________________

Merci de cliquer sur pour chaque message ayant aidé puis sur pour clore cette discussion …

[eric4459]

Bonjour Nonouf,
le fichier joint dans la réponse #10 devrait te convenir
As-tu regardé?
Eric

Marc
Pour ma gouverne, peux-tu me dire ce que tu penses du code en #10?
Merci
Eric

[Nonouf]

Re,

J'ai choisi de compléter la concaténation.
Cela rejoint le début de solution que j'avais imaginé via des formules dans mes feuilles.
Mais tout en vba c'est encore mieux

J'ai testé et cela fonctionne à merveille.

Un grand merci à tous les intervenants.


Nonouf.

[Marc-L]

Pour ma gouverne, peux-tu me dire ce que tu penses du code en #10?

Eric, j'ai un message d'erreur d'un objet manquant sous Excel 2003 …

Sans le temps de détailler, un bon code n'a pas besoin d'Activate ni de Select pour accéder à des objets,
c'est source de ralentissement voire même d'erreur …

[eric4459]

Marc,
J'ai réalisé le code sous Excel 2010 donc l'erreur vient peut-être de là.
C'est vrai que les Select ne sont pas recommandés, je les utilise personnellement pour suivre mes codes en pas à pas, ensuite je les enlève, je n'ai pas vérifié ici.
Mais lorsque j'ai besoin par exemple de couper une partie de la feuille pour la coller dans une autre, il faut bien sélectionner la cellule de départ et la feuille et la cellule de destination, non? comme cet exemple

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
          Col.Offset(2, j).Select
                    Range(Selection, Selection.End(xlToRight)).Select
                    Range(Selection, Selection.End(xlDown)).Select
                    Selection.Copy
 
                    ThisWorkbook.Sheets("Data").Select
                    Range("J12").Select
 
                    Selection.PasteSpecial xlPasteValuesAndNumberFormats

Sinon comment peux-t-on faire?

Peut-on écrire cela par exemple?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
 
                    Range(Col.Offset(2, j), Col.Offset(2, j).End(xlToRight)).Select
                    Range(Col.Offset(2, j), Col.Offset(2, j).End(xlDown)).Select
                    Selection.Copy
 
                   ThisWorkbook.Sheets("Data").Range("J12").PasteSpecial xlPasteValuesAndNumberFormats

Merci pour tes conseils
Eric