Un premier post pour voir

Sub Transfert() 'pour Marion 08/05/2005
Dim i As Byte, L As Byte, Derlgn As Byte, L2 As Byte
Dim derlgn2 As Long
Dim myArray As Variant
Dim TabTemp()
Dim TabTemp2()
Dim maplage As Range, cel As Range
Dim x As Byte, C As Byte
myArray = Array('2', '23', '44', '65', '85') 'limites supérieures des plages RM FLAN etc
For i = 0 To UBound(myArray)
ReDim Preserve TabTemp2(i)
TabTemp2(i) = Range('D' & myArray(i)) 'rempli un tableau des Valeurs RM FLAN en fonction de myArray

Next
With Sheets('Feuil3')
Derlgn = .Range('C65536').End(xlUp).Row
'si la plage feuil3 n'est pas vide on l'efface
If .Cells(2, 3) <> '' Then
.Range(.Cells(2, 3), .Cells(Derlgn, 6)).ClearContents
.Range(.Cells(2, 3), .Cells(Derlgn, 6)).Interior.ColorIndex = 35
Else
With Sheets('Feuil2')

For i = 0 To UBound(myArray) - 1

'on détermine la plage par type RM FLAN etc en fonction des valeurs de myArray
Set maplage = Range(Cells(myArray(i) + 3, 2), Cells(Cells(myArray(i + 1), 2).End(xlUp).Row, 2))
If Cells(myArray(i) + 3, 2) = '' Then
ReDim TabTemp(1, 3)
x = 1
TabTemp(x, 0) = '-'
TabTemp(x, 1) = '-'
TabTemp(x, 2) = '-'
TabTemp(x, 3) = '-'
x = x + 1
GoTo suite
Else
'MsgBox Cells (myArray(i + 1), 2).End(xlUp).Row 'test permet de visualiser la limite inférieur de la zone maplage
x = 1 '
ReDim TabTemp(maplage.Count, 3)
For Each cel In maplage
If cel.Value = '' Then GoTo suivant
'ici on rempli un tableau avec les valeurs de la Zone maplage
TabTemp(x, 0) = cel.Value
TabTemp(x, 1) = cel.Offset(0, 15)
TabTemp(x, 2) = cel.Offset(0, 16)
TabTemp(x, 3) = cel.Offset(0, 17)
x = x + 1
Next
suite:
'Ici copie par Zone
With Worksheets('Feuil3')
Application.ScreenUpdating = False
.Cells(2, 3) = 'carton' 'rempli la cellule H2
.Cells(2, 3).Font.ColorIndex = 5
Derlgn = .Range('C65536').End(xlUp).Row + 1
.Cells(Derlgn, 3) = TabTemp2(L2)
.Cells(Derlgn, 3).Interior.ColorIndex = 6
For L = 1 To UBound(TabTemp, 1)
Derlgn = .Range('C65536').End(xlUp).Row + 1
For C = 0 To UBound(TabTemp, 2)
If C = 4 Then
.Cells(Derlgn, C + 3) = Format(CDate(TabTemp(L, C).Value), 'hh:mm:ss')
Else
.Cells(Derlgn, C + 3) = TabTemp(L, C)
End If
Next
Next
suivant:
L2 = L2 + 1
End With
End If
Next
End With
End If
End With
Application.ScreenUpdating = True
End Sub

Cliquez pour agrandir...