'### Constantes à adapter à votre usage ###
Const SOURCE As String = "Feuil1"
Const DEST As String = "Feuil2"
'##########################################
Sub Transfert_pmo()
Dim S1 As Worksheet
Dim S2 As Worksheet
Dim R1 As Range
Dim R2 As Range
Dim var
Dim i&
Dim j&
Dim nbRow&
On Error GoTo Erreur
Application.ScreenUpdating = False
Set S1 = ActiveWorkbook.Sheets(SOURCE)
Set S2 = ActiveWorkbook.Sheets(DEST)
Set R1 = S1.Range("a1:e" & S1.[a65536].End(xlUp).Row & "")
var = R1
For i& = 2 To UBound(var, 1)
If LCase(var(i&, 5)) = "x" Then
nbRow& = nbRow& + 1
If R2 Is Nothing Then
Set R2 = S1.Range(S1.Cells(i&, 1), S1.Cells(i&, 1))
For j& = 3 To 4
Set R2 = Application.Union(R2, _
S1.Range(S1.Cells(i&, j&), S1.Cells(i&, j&)))
Next j&
Else
For j& = 1 To 4
If j& <> 2 Then
Set R2 = Application.Union(R2, _
S1.Range(S1.Cells(i&, j&), S1.Cells(i&, j&)))
End If
Next j&
End If
End If
Next i&
If R2 Is Nothing Then Exit Sub
With S2
.Activate
.Rows("2:" & nbRow& + 1 & "").Insert Shift:=xlDown
R2.Copy
.[a2].Select
.Paste
.[a1].Select
End With
S1.Activate
Erreur:
Application.ScreenUpdating = True
Application.CutCopyMode = False
If Err <> 0 Then MsgBox "Erreur " & Err.Number & vbCrLf & Err.Description
End Sub