comparaison et copie de cellules excel avec macro

[elijea]

bonjour, j'aimerai avec une macro pouvoir comparer des cellules et faire ressortir un résultat sur une autre feuille
dans mon exemple l'idée est que une même personne ne peut pas avoir a la fois "oui" et "non" ni "oui" et "jamais" donc dans quand ça arrive les lignes ou le cas se présente doivent être copiée dans une autre feuille ou un autre classeur (et pas sur la même feuille comme dans mon image)
merci de votre aide, j'ai un peu de mal , pourtant cela semble assez simple
merci encore

[/url][/IMG]

 

[klin89]

Re : comparaison et copie de cellules excel avec macro

Re elijea,

A tester dans le fichier du post #6

Sub Copie_et_Tri_des_lignes_en_double1()
'Copie et trie en Feuil2 les données de Feuil1
'seules les lignes en double contenant "oui" seront copiées
Application.ScreenUpdating = False
derlign = 1
With Sheets("Feuil1")
 Set Plage = .Range("A1:A" & .Range("A65536").End(xlUp).Row)
 For i = 1 To Plage.Rows.Count
  If Application.CountIf(Plage, .Cells(i, 1).Value) = 2 Then
   Sheets("Feuil2").Cells(derlign, 1).Resize(, 2) = Sheets("Feuil1").Cells(i, 1).Resize(, 2).Value
   derlign = derlign + 1
  End If
 Next i
End With
'Tri_des_données_de_la_Feuil2
'Tri croissant sur la plage champ A
Sheets("Feuil2").Range("A1:B" & Sheets("Feuil2").Range("A65536").End(xlUp).Row).Sort Key1:=Sheets("Feuil2").Range("A1"), _
Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'Puis inversion des blocs de 2 Lignes contenant la chaine "oui"
'qui sera toujours placée en tête
If Application.CountIf(Sheets("Feuil2").Range("B1:B" & Sheets("Feuil2").Range("B65536").End(xlUp).Row), "oui") >= 1 Then
 dl = Sheets("Feuil2").Range("A65536").End(xlUp).Row
 x = 1
 Do
     y = Sheets("Feuil2").Range("A" & x + 1).Row
     If InStr(Sheets("Feuil2").Range("B" & y), "oui") Then
       tablo = Sheets("Feuil2").Range("B" & x & ":B" & y)
       k = 0 'on permute les valeurs des 2 cellules contiguës
      For n = UBound(tablo) To LBound(tablo) Step -1
         Sheets("Feuil2").Range("B" & x + k).Value = tablo(n, 1)
         k = k + 1
       Next n
     End If
     x = y + 1
 Loop Until x > dl
'copie finale
t = Sheets("Feuil2").Range("A1:B" & Cells(Rows.Count, 1).End(xlUp).Row)
 z = 1
 ReDim t2(1 To 2, 1 To z)
 For j = 1 To UBound(t) Step 2
   If t(j, 2) = "oui" Then
     ReDim Preserve t2(1 To 2, 1 To z)
     For m = 1 To 2
       Select Case m
        Case 1
         t2(m, z) = t(j, m)
       Case 2
         t2(m, z) = t(j, m) & " - " & t(j + 1, m)
       End Select
     Next m
     z = z + 1
   End If
 Next j
 Sheets("Feuil2").Range("A1:B" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
 Sheets("Feuil2").Range("A1").Resize(UBound(t2, 2), 2) = Application.Transpose(t2)
Else: MsgBox "Aucune donnée à copier"
Sheets("Feuil2").Range("A1:B" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
End If
Application.ScreenUpdating = True
End Sub

Klin89