Sub INTERROCE2()
Dim Cell As Range
Dim TopCell As Range
Dim BottomCell As Range
With Sheets("Liste_EP")
For Each Cell In .Range("I2:I10") '.Range("I2:I100000")
If Cell.Value = .Range("A3").Value Then
Cell.Activate
'Sélectionner les cellules pleines de la ligne, les copier
If IsEmpty(ActiveCell.Offset(-1, 0)) Then
Set TopCell = ActiveCell
Else
Set TopCell = ActiveCell.End(xlToLeft)
End If
If IsEmpty(ActiveCell.Offset(1, 0)) Then
Set BottomCell = ActiveCell
Else
Set BottomCell = ActiveCell.End(xlToRight)
End If
.Range(TopCell, BottomCell).Copy
With Sheets("BD_CE").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
'Se caler dernière cellule vide de la colonne A,coller la sélection
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Application.Goto reference:=Range("A1"), Scroll:=True
End With
End If
Next Cell
End With
Application.CutCopyMode = False
End Sub