Comparer deux feuilles excel et ajouter le r

bonjour Denys,

si j'ai bien compris copier le résultat de la feuille3 à la fin de la
feuille2, puis trier ?

isabelle

Bonjour,

Essaie comme ceci :

Noms des feuilles à adapter...

'------------------------------------------
Sub test()
Dim Rg As Range, Plg As Range, C As Range
Dim DerLig As Long, Trouve As Range, Adr As String
Dim ModCalcul As Long

Application.ScreenUpdating = False
Application.EnableEvents = False
ModCalcul = Application.Calculation
Application.Calculation = xlCalculationManual

With Worksheets("Feuil1")
Set Rg = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
End With

With Worksheets("Feuil2")
Set Plg = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
End With

With Worksheets("Feuil3")
If Not IsEmpty(.UsedRange) Then
DerLig = .Range("A" & .Cells(.Cells.Count, 1).End(xlUp)).Row + 1
Else
DerLig = 2
End If
End With

For Each C In Rg
With Plg
Set Trouve = .Find(C.Value, after:=.Cells(.Rows.Count, 1), _
LookIn:=xlValues, lookAt:=xlWhole)
If Not Trouve Is Nothing Then
Adr = Trouve.Address
Do
C.Resize(, 21).Copy Feuil4.Range("A" & DerLig)
Trouve.Resize(, 21).Copy Feuil4.Range("A" & DerLig + 1)
DerLig = DerLig + 2
Set Trouve = .FindNext(Trouve)
Loop Until Adr = Trouve.Address
End If
End With
Next
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = ModCalcul
End Sub
'------------------------------------------


MichD
---------------------------------------------------------------

Bonjour Denis,

Ca bug à la Feuil4....il recherche un objet.... J'ai quatre feuilles tell es que nommées ci-dessous....

Sub test()
Dim Rg As Range, Plg As Range, C As Range
Dim DerLig As Long, Trouve As Range, Adr As String
Dim ModCalcul As Long

Application.ScreenUpdating = False
Application.EnableEvents = False
ModCalcul = Application.Calculation
Application.Calculation = xlCalculationManual

With Worksheets("SRF_Address")' Feuil1
Set Rg = .Range("a1:a" & .Cells(.Rows.Count, "A").End(xlUp).Row)
End With

With Worksheets("SRF Product Summary")' Feuil2
Set Plg = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
End With

With Worksheets("TEST2")' Feuil3
If Not IsEmpty(.UsedRange) Then
DerLig = .Range("A" & .Cells(.Cells.Count, 1).End(xlUp)).Row + 1
Else
DerLig = 2
End If
End With

For Each C In Rg
With Plg
Set Trouve = .Find(C.Value, after:=.Cells(.Rows.Count, 1), _
LookIn:=xlValues, lookAt:=xlWhole)
If Not Trouve Is Nothing Then
Adr = Trouve.Address
Do
Ici--------> C.Resize(, 21).Copy Feuil4.Range("A" & DerLig)' Feuil4
Trouve.Resize(, 21).Copy Feuil4.Range("A" & DerLig + 1)
DerLig = DerLig + 2
Set Trouve = .FindNext(Trouve)
Loop Until Adr = Trouve.Address
End If
End With
Next
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = ModCalcul
End Sub

Merci.....

Denys

Remplace la Feuil4 par Worksheets("TEST2")
ou le nom de la feuille où doit se faire la copie

MichD
---------------------------------------------------------------

Bonjour Denis,

J'avais essayé sous 2003, mais ça ne fonctionnait pas......puis j'ai es sayé sous un PC avec Excel 2010 et pouf !!! Tout fonctionne à merveille .... Ca prend quand même 20 minutes.....faut dire qu'il y a plus de 24,00 0 lignes au total !!!!

Merci infiniment....

Denys

Si tu veux avoir quelque chose de plus performant
il faut d'abord que tu présentes tes feuilles de données.

J'ai supposé que la feuil2 et la feuil3 dans la procédure
avaient une ligne d'étiquettes de colonne (la même)

La ligne du début des données débutant en ligne 2 pour les 2 feuilles

Feuil4 est la feuille qui reçoit le résultat dans la procédure.

Débute d'abord par adapter le nom des feuilles.

'-----------------------------------------
Sub test()
Dim DerLig As Long, LastRow As Long, Plg As Range
Dim Sh As Worksheet, Rg As Range, ModCalcul As Long

Application.ScreenUpdating = False
ModCalcul = Application.Calculation
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Set Sh = Worksheets.Add

With Feuil2
DerLig = .Cells.Find("*", LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
Set Rg = .Range("A1:U" & DerLig)
Rg.Copy Sh.Range("A1")
End With
With Feuil3
LastRow = .Cells.Find("*", LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
Set Plg = .Range("A2:U" & LastRow)
Plg.Resize(, 21).Copy Sh.Range("A" & DerLig + 1)
End With

With Sh
.Range("Z1") = ""
.Range("Z2").Formula = "=Countif(" & .Name & "!" & .Range("$A$1:$A$" & _
(DerLig + 1 + LastRow)).Address & "," & _
.Name & "!" & .Range("$A$2").Address(0, 0) & ")>=2"
With .Range("A1:A" & .Cells(.Cells.Rows.Count, 1).End(xlUp).Row)
.AdvancedFilter xlFilterInPlace, Criteriarange:=Sh.Range("Z1:Z2"),
Unique:úlse
.Resize(, 21).SpecialCells(xlCellTypeVisible).Copy
Feuil4.Range("A1")
End With
End With
With Feuil4
With .Range("A1:U" & DerLig + 1 + LastRow)
.Sort .Item(1, 1), xlAscending, Header:=xlYes
End With
End With

Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True

Application.Calculation = ModCalcul
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
'-----------------------------------------

MichD
---------------------------------------------------------------

Excellent....

Merci beaucoup Denis. Cela m'apporte un grande aide.....

Bonne journée

Denys