VBA Exploration et Copie

**naozumi8** · 19/04/2024, 13h37

Bonjour à tous

Voici mon code VBA en l'état :

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
78
79
80
81
82
83
84
Option Explicit
 
Sub MAJGroupe()
    Dim wsGlobal As Worksheet
    Dim wsOld As Worksheet
    Dim lastRowGlobal As Long
    Dim lastRowOld As Long
    Dim idRangeGlobal As Range
    Dim statutRangeOld As Range
    Dim idRangeOld As Range
    Dim groupeRangeOld As Range
    Dim statutCell As Range
    Dim idCell As Range
    Dim groupeCell As Range
    Dim matchCellGlobal As Range
    Dim matchCellGroup As Range
    Dim matchCellOldID As Range
	Dim i As Integer
    Dim Couleurs As Variant
 
    Set wsGlobal = ThisWorkbook.Sheets("Global")
	On Error Resume Next
    Set wsOld = ThisWorkbook.Sheets("Extract")
	On Error GoTo 0
 
	' Si la feuille "Extract" n'existe pas, afficher un message et quitter la macro
    If wsOld Is Nothing Then
        MsgBox "La feuille 'Extract' n'a pas été trouvée. La prise en compte de l'ancien Backlog n'as pu donc être effectuée.Merci de cliquer sur CREER", vbExclamation
        Exit Sub
    End If
 
    lastRowGlobal = wsGlobal.Cells(wsGlobal.Rows.Count, "A").End(xlUp).Row
    lastRowOld = wsOld.Cells(wsOld.Rows.Count, "A").End(xlUp).Row
 
    Set idRangeGlobal = wsGlobal.Range("A2:A" & lastRowGlobal)
    Set statutRangeOld = wsOld.Range("E2:E" & lastRowOld)
    Set idRangeOld = wsOld.Range("A2:A" & lastRowOld)
    Set groupeRangeOld = wsOld.Range("L2:L" & lastRowOld)
 
    ' Parcourir chaque cellule de la colonne "A" de la feuille "Global"
    For Each idCell In idRangeGlobal
        ' Recherche de la correspondance dans la feuille "Extract" en utilisant l'identifiant commun
        Set matchCellOldID = idRangeOld.Find(idCell.Value, LookIn:=xlValues)
 
        If matchCellOldID Is Nothing Then
            ' Si l'identifiant n'est pas trouvé dans la feuille "Extract", alors mettre "Résolu" dans la ligne correspondante
            wsGlobal.Range("E" & idCell.Row).Value = "Résolu"
            wsGlobal.Range("M" & idCell.Row).Value = "Résolu"
 
            ' Colorier la ligne dans la feuille "Global"
            wsGlobal.Range("A" & idCell.Row & ":N" & idCell.Row).Interior.Color = RGB(169, 208, 142)
 
            ' Utilisation du groupe pour déterminer la feuille destination
            Dim wsGlobalGroup As Worksheet
            On Error Resume Next
            Set wsGlobalGroup = ThisWorkbook.Sheets(wsGlobal.Range("L" & idCell.Row).Value)
            On Error GoTo 0
 
            If Not wsGlobalGroup Is Nothing Then
                ' Recherche de la correspondance dans la feuille du groupe en utilisant l'identifiant commun
                Set matchCellGroup = wsGlobalGroup.Range("A:A").Find(idCell.Value, LookIn:=xlValues)
 
                If Not matchCellGroup Is Nothing Then
                    ' Mettre "Résolu" dans la ligne correspondante de la feuille du groupe
                    wsGlobalGroup.Range("E" & matchCellGroup.Row).Value = "Résolu"
                    wsGlobalGroup.Range("M" & matchCellGroup.Row).Value = "Résolu"
 
                    ' Colorier la ligne dans la feuille du groupe
                    wsGlobalGroup.Range("A" & matchCellGroup.Row & ":N" & matchCellGroup.Row).Interior.Color = RGB(169, 208, 142)
                End If
            End If
        End If
    Next idCell
 
     ' Supprimer la feuille "Extract" à la fin
  ThisWorkbook.Worksheets("Extract").Delete ' Supprimer la feuille "Extract"
 
 
 
    Application.ScreenUpdating = True ' Réactiver la mise à jour de l'écran
 
 
 
End Sub

je voudrais y incorporer une fonction qui :
- Parcours chaque cellule de la colonne "A" de la feuille "Extract" et Recherche la correspondance dans la feuille "Global" en utilisant l'identifiant commun
- Si l'identifiant n'est pas trouvé dans la feuille "Global" Alors Copier la ligne (de A à N) de la feuille Extract vers la feuille Global ainsi que sur les feuilles se nommant dans la cellule de la colonne L de plus mettre cette ligne de couleur RGB(248, 203, 173)

Merci d'avance

**deedolith** · 19/04/2024, 14h11

Salut,

Je te propose une solution basée sur PowerQuery et du formattage conditionnel.
Rechercher des non correspondances, mettre des lignes en surbrillances, c'est trivial avec ces outils.

Exemple ci dessous:
Developpez.com.xlsx

**naozumi8** · 19/04/2024, 15h07

Envoyé par deedolith

Salut,

Je te propose une solution basée sur PowerQuery et du formattage conditionnel.
Rechercher des non correspondances, mettre des lignes en surbrillances, c'est trivial avec ces outils.

Exemple ci dessous:
Developpez.com.xlsx

Merci de ton retour, mais je préfèrerais intégrer cela au code VBA

**naozumi8** · 19/04/2024, 15h15

j'ai essayé avec ce code là :

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
78
79
80
Option Explicit
 
Sub MajService()
    Dim wsGlobal As Worksheet
    Dim wsOld As Worksheet
    Dim lastRowGlobal As Long
    Dim lastRowOld As Long
    Dim idRangeGlobal As Range
    Dim statutRangeOld As Range
    Dim idRangeOld As Range
    Dim ServiceRangeOld As Range
    Dim statutCell As Range
    Dim idCell As Range
    Dim groupeCell As Range
    Dim matchCellGlobal As Range
    Dim matchCellGroup As Range
    Dim matchCellOldID As Range
    Dim i As Integer
    Dim Couleurs As Variant
    Dim wsGlobalGroup As Worksheet
    Dim copyRange As Range
 
    Set wsGlobal = ThisWorkbook.Sheets("Global")
    On Error Resume Next
    Set wsOld = ThisWorkbook.Sheets("Extract")
    On Error GoTo 0
 
    ' Si la feuille "Extract" n'existe pas, afficher un message et quitter la macro
    If wsOld Is Nothing Then
        MsgBox "La feuille 'Extract' n'a pas été trouvée. La prise en compte de l'ancien Backlog n'a donc pu être effectuée.", vbExclamation
        Exit Sub
    End If
 
    lastRowGlobal = wsGlobal.Cells(wsGlobal.Rows.Count, "A").End(xlUp).Row
    lastRowOld = wsOld.Cells(wsOld.Rows.Count, "A").End(xlUp).Row
 
    Set idRangeGlobal = wsGlobal.Range("A2:A" & lastRowGlobal)
    Set statutRangeOld = wsOld.Range("E2:E" & lastRowOld)
    Set idRangeOld = wsOld.Range("A2:A" & lastRowOld)
    Set ServiceRangeOld = wsOld.Range("B2:B" & lastRowOld)
 
    ' Parcourir chaque cellule de la colonne "A" de la feuille "Extract"
    For Each idCell In idRangeOld
        ' Recherche de la correspondance dans la feuille "Global" en utilisant l'identifiant commun
        Set matchCellOldID = idRangeGlobal.Find(idCell.Value, LookIn:=xlValues)
 
        If matchCellOldID Is Nothing Then
            ' Si l'identifiant n'est pas trouvé dans la feuille "Global"
            ' Copier la ligne de la feuille "Extract" vers la feuille "Global"
            wsOld.Range("A" & idCell.Row & ":N" & idCell.Row).Copy
            wsGlobal.Cells(lastRowGlobal + 1, 1).PasteSpecial xlPasteValues
            ' Mettre la couleur sur la ligne copiée
            Set copyRange = wsGlobal.Range(wsGlobal.Cells(lastRowGlobal + 1, 1), wsGlobal.Cells(lastRowGlobal + 1, 14))
            copyRange.Interior.Color = RGB(248, 203, 173)
            ' Mettre la même ligne sur les feuilles correspondantes
            For Each groupeCell In wsGlobal.Range("L2:L" & lastRowGlobal)
                Set wsGlobalGroup = ThisWorkbook.Sheets(groupeCell.Value)
                If Not wsGlobalGroup Is Nothing Then
                    copyRange.Copy wsGlobalGroup.Cells(wsGlobalGroup.Rows.Count, "A").End(xlUp).Offset(1, 0)
                    wsGlobalGroup.Cells(wsGlobalGroup.Rows.Count, "A").End(xlUp).Offset(1, 0).Interior.Color = RGB(248, 203, 173)
                End If
            Next groupeCell
            lastRowGlobal = wsGlobal.Cells(wsGlobal.Rows.Count, "A").End(xlUp).Row
        End If
    Next idCell
 
    ' Supprimer la feuille "Extract" à la fin
    Application.DisplayAlerts = False ' Désactiver les alertes pour la suppression
    ThisWorkbook.Worksheets("Extract").Delete ' Supprimer la feuille "Extract"
    Application.DisplayAlerts = True ' Réactiver les alertes
 
    'Coloriser onglets
    Couleurs = Array(32768, 16711680, 15631086, 55295, 8388736, 65535, 16777200, 8894686)
    For i = 1 To ActiveWorkbook.Sheets.Count
        With ActiveWorkbook.Sheets(i).Tab
            .Color = Couleurs(i Mod 8)
            .TintAndShade = 0
        End With
    Next i
End Sub

Ce qui me copie bien la donnée de Extract vers Global mais ne répercute pas sur les autres feuilles (se nommant dans la cellule de la colonne L)

**Valtrase** · 19/04/2024, 18h34

Bonjour,
Un fichier sans données sensible serait le bienvenue.
De plus je vois quelques contradictions entre les explications et certaines lignes de codes.
Donc confirmez-vous que si les valeurs de la colonne A du fichier Extract ne sont pas trouvées dans la colonne A du fichier global alors

On copie, colle la plage "A:N" de la ligne de l'index qui n'a pas été trouvé sur le même numéro de ligne de la feuille global
On colorie cette même ligne
On récupère le nom d'une feuille situé en colonne "L" de la feuille Extract
On recopie cette ligne sur la feuille de la colonne "L" de la nouvelle feuille
On colorie cette ligne

Sinon

On note "Résolu" dans les colonnes "E" et "M" de la feuille Extract

**naozumi8** · 22/04/2024, 10h26

Bon du coup j'ai fait cela qui a l'air d'être fonctionnel :

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
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
Option Explicit
 
Sub MajService()
    Dim wsGlobal As Worksheet
    Dim wsOld As Worksheet
    Dim lastRowGlobal As Long
    Dim lastRowOld As Long
    Dim idRangeGlobal As Range
    Dim statutRangeOld As Range
    Dim idRangeOld As Range
    Dim ServiceRangeOld As Range
    Dim statutCell As Range
    Dim idCell As Range
    Dim groupeCell As Range
    Dim matchCellGlobal As Range
    Dim matchCellGroup As Range
    Dim matchCellOldID As Range
    Dim i As Integer
    Dim Couleurs As Variant
    Dim wsGlobalGroup As Worksheet
    Dim copyRange As Range
	Dim groupName As String
	Dim lastRowGroup As Long
 
    Set wsGlobal = ThisWorkbook.Sheets("Global")
    On Error Resume Next
    Set wsOld = ThisWorkbook.Sheets("Extract")
    On Error GoTo 0
 
    ' Si la feuille "Extract" n'existe pas, afficher un message et quitter la macro
    If wsOld Is Nothing Then
        MsgBox "La feuille 'Extract' n'a pas été trouvée. La prise en compte de l'ancien Backlog n'a donc pu être effectuée.", vbExclamation
        Exit Sub
    End If
 
    lastRowGlobal = wsGlobal.Cells(wsGlobal.Rows.Count, "A").End(xlUp).Row
    lastRowOld = wsOld.Cells(wsOld.Rows.Count, "A").End(xlUp).Row
 
    Set idRangeGlobal = wsGlobal.Range("A2:A" & lastRowGlobal)
    Set statutRangeOld = wsOld.Range("E2:E" & lastRowOld)
    Set idRangeOld = wsOld.Range("A2:A" & lastRowOld)
    Set ServiceRangeOld = wsOld.Range("B2:B" & lastRowOld)
 
 
 
	' Parcourir chaque cellule de la colonne "A" de la feuille "Global"
    For Each idCell In idRangeGlobal
        ' Recherche de la correspondance dans la feuille "Extract" en utilisant l'identifiant commun
        Set matchCellOldID = idRangeOld.Find(idCell.Value, LookIn:=xlValues)
 
        If matchCellOldID Is Nothing Then
            ' Si l'identifiant n'est pas trouvé dans la feuille "Extract", alors mettre "Résolu" dans la ligne correspondante
            wsGlobal.Range("E" & idCell.Row).Value = "Résolu"
            wsGlobal.Range("M" & idCell.Row).Value = "Résolu"
 
            ' Colorier la ligne dans la feuille "Global"
            wsGlobal.Range("A" & idCell.Row & ":N" & idCell.Row).Interior.Color = RGB(169, 208, 142)
 
            ' Utilisation du Service pour déterminer la feuille destination
            On Error Resume Next
            Set wsGlobalGroup = ThisWorkbook.Sheets(wsGlobal.Range("B" & idCell.Row).Value)
            On Error GoTo 0
 
            If Not wsGlobalGroup Is Nothing Then
                ' Recherche de la correspondance dans la feuille du Service en utilisant l'identifiant commun
                Set matchCellGroup = wsGlobalGroup.Range("A:A").Find(idCell.Value, LookIn:=xlValues)
 
                If Not matchCellGroup Is Nothing Then
                    ' Mettre "Résolu" dans la ligne correspondante de la feuille du Service
                    wsGlobalGroup.Range("E" & matchCellGroup.Row).Value = "Résolu"
                    wsGlobalGroup.Range("M" & matchCellGroup.Row).Value = "Résolu"
 
                    ' Colorier la ligne dans la feuille du Service
                    wsGlobalGroup.Range("A" & matchCellGroup.Row & ":N" & matchCellGroup.Row).Interior.Color = RGB(169, 208, 142)
                End If
            End If
        End If
    Next idCell
 
 
 
 
    ' Parcourir chaque cellule de la colonne "A" de la feuille "Extract"
    For Each idCell In idRangeOld
        ' Recherche de la correspondance dans la feuille "Global" en utilisant l'identifiant commun
        Set matchCellOldID = idRangeGlobal.Find(idCell.Value, LookIn:=xlValues)
 
        If matchCellOldID Is Nothing Then
            ' Si l'identifiant n'est pas trouvé dans la feuille "Global"
            ' Copier la ligne de la feuille "Extract" vers la feuille "Global"
            wsOld.Range("A" & idCell.Row & ":N" & idCell.Row).Copy
            wsGlobal.Cells(lastRowGlobal + 1, 1).PasteSpecial xlPasteValues
            ' Mettre la couleur sur la ligne copiée
            Set copyRange = wsGlobal.Range(wsGlobal.Cells(lastRowGlobal + 1, 1), wsGlobal.Cells(lastRowGlobal + 1, 14))
            copyRange.Interior.Color = RGB(248, 203, 173)
 
		   ' Mettre la même ligne sur les feuilles correspondantes
		   	groupName = wsOld.Cells(idCell.Row, "B").Value
			Set wsGlobalGroup = ThisWorkbook.Sheets(groupName)
			If Not wsGlobalGroup Is Nothing Then
			' Copier la ligne de la feuille "Extract" vers la feuille correspondante
			wsOld.Range("A" & idCell.Row & ":N" & idCell.Row).Copy wsGlobalGroup.Cells(wsGlobalGroup.Rows.Count, "A").End(xlUp).Offset(1, 0)
			'Insérer une ligne après avoir copié les données
			wsGlobalGroup.Cells(wsGlobalGroup.Rows.Count, "A").End(xlUp).Offset(1).EntireRow.Insert Shift:=xlDown
			wsGlobalGroup.Cells(wsGlobalGroup.Rows.Count, "A").End(xlUp).Offset(1).EntireRow.Interior.Pattern = xlNone
			wsGlobalGroup.Cells(wsGlobalGroup.Rows.Count, "A").End(xlUp).Offset(1).EntireRow.Interior.TintAndShade = 0
			wsGlobalGroup.Cells(wsGlobalGroup.Rows.Count, "A").End(xlUp).Offset(1).EntireRow.Interior.PatternTintAndShade = 0
 
			' Colorier la ligne dans la feuille correspondante
			wsGlobalGroup.Cells(wsGlobalGroup.Rows.Count, "A").End(xlUp).Offset(0, 0).Resize(1, 14).Interior.Color = RGB(248, 203, 173)
 
 
	End If
 
        End If
    Next idCell
 
	Range("A1").Select
 
    ' Supprimer la feuille "Extract" à la fin
    Application.DisplayAlerts = False ' Désactiver les alertes pour la suppression
    ThisWorkbook.Worksheets("Extract").Delete ' Supprimer la feuille "Extract"
    Application.DisplayAlerts = True ' Réactiver les alertes
 
    'Coloriser onglets
    Couleurs = Array(32768, 16711680, 15631086, 55295, 8388736, 65535, 16777200, 8894686)
    For i = 1 To ActiveWorkbook.Sheets.Count
        With ActiveWorkbook.Sheets(i).Tab
            .Color = Couleurs(i Mod 8)
            .TintAndShade = 0
        End With
    Next i
 
	' Tri pour la feuille "Global"
wsGlobal.Range("A2:N" & lastRowGlobal).Sort Key1:=wsGlobal.Range("F2"), Order1:=xlAscending, Header:=xlYes
wsGlobal.Range("A2:N" & lastRowGlobal).Sort Key1:=wsGlobal.Range("L2"), Order1:=xlAscending, Header:=xlYes
 
' Tri pour chaque feuille de service
For Each wsGlobalGroup In ThisWorkbook.Worksheets
    If wsGlobalGroup.Name <> "Global" Then
        lastRowGroup = wsGlobalGroup.Cells(wsGlobalGroup.Rows.Count, "A").End(xlUp).Row
        wsGlobalGroup.Range("A2:N" & lastRowGroup).Sort Key1:=wsGlobalGroup.Range("F2"), Order1:=xlAscending, Header:=xlYes
        wsGlobalGroup.Range("A2:N" & lastRowGroup).Sort Key1:=wsGlobalGroup.Range("L2"), Order1:=xlAscending, Header:=xlYes
    End If
Next wsGlobalGroup
 
 
End Sub

or copie les données sur la feuille global toujours sur la meme ligne

VBA Exploration et Copie

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager