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
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
si j'ai bien compris copier le résultat de la feuille3 à la fin de la
feuille2, puis trier ?
isabelle
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
---------------------------------------------------------------
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
ou le nom de la feuille où doit se faire la copie
MichD
---------------------------------------------------------------
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
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
---------------------------------------------------------------
Merci beaucoup Denis. Cela m'apporte un grande aide.....
Denys