Repport des differences
Bonjour,
J'ai besoin d'aide pour modifier le code suivant :
Sub AvecCopierColler()
Dim Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet, C1 As Byte, C2 As Byte, Derlign As Long
Set Ws1 = Sheets("Feuil1")
Set Ws2 = Sheets("Feuil2")
Set Ws3 = Sheets("Synthese")
Application.ScreenUpdating = False
For i = 2 To Ws1.Range("A65000").End(xlUp).Row
For j = 2 To Ws2.Range("A65000").End(xlUp).Row
If Ws1.Cells(i, 1) = Ws2.Cells(j, 1) Then
Derlign = Ws3.Range("A65000").End(xlUp).Row + 1
With Ws1
C1 = .Cells(i, 1).End(xlToRight).Column
.Range(.Cells(i, 1), .Cells(i, C1)).Copy
Ws3.Cells(Derlign, 1).PasteSpecial Paste:=xlValues
End With
With Ws2
C2 = .Cells(i, 1).End(xlToRight).Column
.Range(.Cells(j, 2), .Cells(j, C2)).Copy
Ws3.Cells(Derlign, C1 + 1).PasteSpecial Paste:=xlValues
End With
Application.CutCopyMode = False
End If
Next
Next
Application.ScreenUpdating = True
End Subsi sur une mème ligne la cellule de "Feuil1" est = à ("Feuil2") repport sur la "Synthese"
idem
si sur une mème ligne la cellule de "Feuil2" est = à ("Feuil1") repport sur la "Synthese"
et ainsi de suite ...
Maintenant je cherche à obtenir et ni arrivant pas je sollicite encore une fois votre aide :
si sur une mème ligne la cellule de "Feuil1" est différente à ("Feuil2") repport sur la "Synthese"
idem
si sur une mème ligne la cellule de "Feuil2" est différente à ("Feuil1") repport sur la "Synthese"
et ainsi de suite ...... et donc ne repporte plus les identiques ..... mais uniquement que les différents.
Merci
Bonjour
Voilà une solution qui devrait fonctionner pour trouver les différences.
Sub AvecCopierColler()
Dim Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet
Dim C1 As Byte, C2 As Byte, Derlign As Long, IdemTrouve As Boolean
Set Ws1 = Sheets("Feuil1")
Set Ws2 = Sheets("Feuil2")
Set Ws3 = Sheets("Synthese")
Application.ScreenUpdating = False
' Recherche des différences dans 'Feuil1'
For i = 2 To Ws1.Range("A65000").End(xlUp).Row
IdemTrouve = False
For j = 2 To Ws2.Range("A65000").End(xlUp).Row
If Ws1.Cells(i, 1) = Ws2.Cells(j, 1) Then
IdemTrouve = True
Exit For
End If
Next
If Not (IdemTrouve) Then
Derlign = Ws3.Range("A65000").End(xlUp).Row + 1
With Ws1
C1 = .Cells(i, 1).End(xlToRight).Column
.Range(.Cells(i, 1), .Cells(i, C1)).Copy
Ws3.Cells(Derlign, 1).PasteSpecial Paste:=xlValues
End With
Application.CutCopyMode = False
End If
Next
' Recherche des différences dans 'Feuil2'
For i = 2 To Ws2.Range("A65000").End(xlUp).Row
IdemTrouve = False
For j = 2 To Ws1.Range("A65000").End(xlUp).Row
If Ws1.Cells(i, 1) = Ws2.Cells(j, 1) Then
IdemTrouve = True
Exit For
End If
Next
If Not (IdemTrouve) Then
Derlign = Ws3.Range("A65000").End(xlUp).Row + 1
With Ws2
C2 = .Cells(i, 1).End(xlToRight).Column
.Range(.Cells(j, 2), .Cells(j, C2)).Copy
Ws3.Cells(Derlign, C1 + 1).PasteSpecial Paste:=xlValues
End With
Application.CutCopyMode = False
End If
Next
Application.ScreenUpdating = True
End SubElle n'est pas testée. Si tu as des problèmes, n'hésite pas à le faire savoir.
Cordialement
Dan_de_pic
Bonsoir Dan_de_pic,
Merci pour ton intervention. Ton code fonctionne parfaitement, mais ne fait que les repports de la feuil1, je cherche également que ceux de la feuill2 apparaissent.
Ci-joint un fichier explicative.
https://www.excel-pratique.com/~files/doc/qQJoAREGROUPER_DIFF1.xls
Dans l'attente de te lire.
Merci
Bonsoir
Il y avait effectivement quelques erreurs dans les lignes au bas de la macro.
https://www.excel-pratique.com/~files/doc/GROUPER_DIFF.xls
A te relire
Bonne soirée
Dan_de_pic
Bonjour Dan_de_pic,
A+