Bonjour,
[Suite MP] : adaptation de la macro de ton sujet précédent à ta nouvelle configuration...
Sub Transfert()
Dim tft(), i%, f%, wb As Workbook
On Error GoTo nowb
Set wb = Workbooks("Sortie.xlsx")
On Error GoTo 0
ReDim tft(6, 0)
With ThisWorkbook
For f = 1 To .Worksheets.Count
Select Case .Worksheets(f).Name
Case "Recap1", "Recap2", "Recap3", "Recap4"
Case Else
tft(0, 0) = tft(0, 0) + 1
ReDim Preserve tft(6, tft(0, 0))
With .Worksheets(f)
tft(0, tft(0, 0)) = .Name
For i = 1 To 6
tft(i, tft(0, 0)) = .Cells(i + 1, 4)
Next i
End With
End Select
Next f
End With
For f = 1 To tft(0, 0)
On Error Resume Next
With wb.Worksheets(tft(0, f))
If Err.Number <> 0 Then
Err.Clear: GoTo nofeuil
End If
For i = 1 To 6
.Cells(i + 1, 4) = tft(i, f)
Next i
End With
nofeuil:
Next f
Exit Sub
nowb:
'Set wb = Workbooks.Open("chemin\Sortie.xlsx")
'Resume Next
End Sub
Même schéma. Macro dans le classeur Entrée.
Cordialement.