XL 2016 Comparer deux plages

KTM

XLDnaute Impliqué
Bonjour chers Amis du Forum
J'ai une plage1 de cellules ou sont enregistrés les Personnes attendues et une autre plage2 pour les personnes recues.
Je voudrais à l'aide d'une macro extraire sur la plage3 les personnes ayant maquer de venir au Rendez vous
Je joins un fichier exemple
Merci infiniment
 

Pièces jointes

  • ComparePlage.xlsm
    11.7 KB · Affichages: 12

KTM

XLDnaute Impliqué

Pièces jointes

  • ComparePlage.xlsm
    10.6 KB · Affichages: 7

job75

XLDnaute Barbatruc
Bonjour KTM, Pierre, le forum,

Voyez le fichier joint et cette macro dans le code de la feuille :
VB:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [L1]) Is Nothing Then Exit Sub
Dim deb1 As Range, deb2 As Range, d As Object, ncol%, tablo, i&, x$, j%
Cancel = True
Set deb1 = [B1]: Set deb2 = [G1]
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
'---liste des attendus---
With deb1.CurrentRegion.Offset(1)
    ncol = .Columns.Count
    If ncol = 1 Then ncol = 2
    tablo = .Resize(, ncol)
End With
For i = 1 To UBound(tablo)
    x = ""
    For j = 1 To ncol
        x = x & Chr(1) & tablo(i, j)
    Next j
    d(Mid(x, 2)) = ""
Next i
'---élimination des reçus---
tablo = deb2.CurrentRegion.Offset(1).Resize(, ncol)
For i = 1 To UBound(tablo)
    x = ""
    For j = 1 To ncol
        x = x & Chr(1) & tablo(i, j)
    Next j
    x = Mid(x, 2)
    If d.exists(x) Then d.Remove x
Next i
'---restitution des manquants---
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If FilterMode Then ShowAllData
With Target(2, 1)
    .Resize(Rows.Count - .Row + 1, ncol).ClearContents 'RAZ
    If d.Count = 0 Then Exit Sub
    With .Resize(d.Count)
        .Value = Application.Transpose(d.keys) 'Transpose est limitée à 65536 lignes
        .TextToColumns .Cells(1), xlDelimited, Other:=True, OtherChar:=Chr(1)  'commande Convertir
    End With
End With
End Sub
Double-clic sur MANQUES.

Bonne journée.
 

Pièces jointes

  • ComparePlage(1).xlsm
    21.1 KB · Affichages: 8

KTM

XLDnaute Impliqué
Bonjour KTM, Pierre, le forum,

Voyez le fichier joint et cette macro dans le code de la feuille :
VB:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [L1]) Is Nothing Then Exit Sub
Dim deb1 As Range, deb2 As Range, d As Object, ncol%, tablo, i&, x$, j%
Cancel = True
Set deb1 = [B1]: Set deb2 = [G1]
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
'---liste des attendus---
With deb1.CurrentRegion.Offset(1)
    ncol = .Columns.Count
    If ncol = 1 Then ncol = 2
    tablo = .Resize(, ncol)
End With
For i = 1 To UBound(tablo)
    x = ""
    For j = 1 To ncol
        x = x & Chr(1) & tablo(i, j)
    Next j
    d(Mid(x, 2)) = ""
Next i
'---élimination des reçus---
tablo = deb2.CurrentRegion.Offset(1).Resize(, ncol)
For i = 1 To UBound(tablo)
    x = ""
    For j = 1 To ncol
        x = x & Chr(1) & tablo(i, j)
    Next j
    x = Mid(x, 2)
    If d.exists(x) Then d.Remove x
Next i
'---restitution des manquants---
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If FilterMode Then ShowAllData
With Target(2, 1)
    .Resize(Rows.Count - .Row + 1, ncol).ClearContents 'RAZ
    If d.Count = 0 Then Exit Sub
    With .Resize(d.Count)
        .Value = Application.Transpose(d.keys) 'Transpose est limitée à 65536 lignes
        .TextToColumns .Cells(1), xlDelimited, Other:=True, OtherChar:=Chr(1)  'commande Convertir
    End With
End With
End Sub
Double-clic sur MANQUES.

Bonne journée.
Merci Job75
Super!!!
Mais je Préfère associer ce code a un bouton
Encore Merci
 

Discussions similaires

Statistiques des forums

Discussions
312 177
Messages
2 085 976
Membres
103 076
dernier inscrit
LoneWolf90