Comparer deux feuilles excel et ajouter le r

Le
Denys
Bonjour,

J'utilise la macro suivante pour comparer deux feuilles et envoyer le rÃ=
©sultat vers une troisième

Sub aa()
With Sheets("Sheet1")
For Each c In .Range("a1:a" & .Cells(Rows.Count, "a").End(3).Row)
If IsError(Application.Match(c, Sheets("Sheet2"). _
Range("a1:a" & Sheets("Sheet2").Cells(Rows.Count, "a").End(3).Row), 0)) T=
hen
X = X + 1
.Rows(c.Row).Copy Sheets("Sheet3").Range("a" & X)
End If
Next
End With
End Sub

Cela copie la ligne de la feuille 1 si dans la feuille 3 si le nombre dans =
la colonne a de la feuille 1 se retrouve aussi dans le feuille 2.

Cependant, je voudrais que non seulement la ligne de la feuille 1 se copie =
(colonne A à U), mais aussi la ligne de la feuille deux, de la colonne=
A à la colonne U à la suite de façon à combiner les co=
lonnes des deux lignes correspondantes de la page 1 et page 2.

J'espère que c'est compr♪hensible
Merci pour votre temps
Denys
Questions / Réponses high-tech
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
isabelle
Le #25616522
bonjour Denys,

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

isabelle
MichD
Le #25616592
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
---------------------------------------------------------------
Denys
Le #25616702
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
MichD
Le #25616722
Remplace la Feuil4 par Worksheets("TEST2")
ou le nom de la feuille où doit se faire la copie

MichD
---------------------------------------------------------------
Denys
Le #25616822
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
MichD
Le #25617002
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
---------------------------------------------------------------
Denys
Le #25663682
Excellent....

Merci beaucoup Denis. Cela m'apporte un grande aide.....
Denys
Le #25663672
Bonne journée

Denys
Publicité
Poster une réponse
Anonyme