Option Explicit
Option Base 1
'====================================
Sub Balayage2()
Dim cl
Dim mtR1, mtR2, mtC1, mtC2, mtNbR, mtNbC, valTrim As Integer
Dim inc, inc2, x As Integer
Dim code As String
Dim mtCopie As Range
Dim array_copy()
'===================================
'Un petit chrono ?
Dim StartTime1, StartTime2 As Double
Application.ScreenUpdating = False
StartTime1 = Timer
'===================================
'Boucle sur première colonne zone extract
For Each cl In Range("B3:B23")
If Not IsNumeric(cl) Then 'Début d'un mini tableau
cl.Activate
'validation des variables de dimension du mini tableau
mtR1 = cl.Row
mtC1 = cl.Column
Selection.End(xlToRight).Activate
mtC2 = ActiveCell.Column
mtNbC = mtC2 - mtC1 + 1
'boucle de comptage des lignes
Do
inc = inc + 1
Loop While IsNumeric(Cells(mtR1 + 1 + inc, mtC2)) And (Cells(mtR1 + 1 + inc, mtC2)) <> ""
mtNbR = inc + 1
mtR2 = mtR1 + mtNbR - 1
valTrim = (mtC2 - mtC1) / 3
inc = 0 'RAZ compteur
''+++++MSGBOX DE VERIFICATION DES DIMENSIONS DU MINI TABLEAU
''===========a décommenter si besoin============
' MsgBox "mtR1: N°ligne départ" & vbTab & mtR1 & vbCr & _
"mtR2: N°ligne fin" & vbTab & mtR2 & vbCr & _
"mtNbR: Total lignes" & vbTab & mtNbR & vbCr & _
"mtC1: N°col départ" & vbTab & mtC1 & vbCr & _
"mtC2: N°col fin" & vbTab & mtC2 & vbCr & _
"mtNbC: Total col" & vbTab & mtNbC & vbCr & _
"valTrim: Val/trim" & vbTab & valTrim
'===================================
'Boucle de sélection des données en colonnes de chaque mini tableau
x = 0
For inc2 = mtC1 To mtC1 + (valTrim * 2) - 1
x = x + 1
code = Cells(mtR1, inc2) 'Recherche du code pour la boucle SELECT CASE
'Déclaration de la zone à transférer en range
Set mtCopie = Range(Cells(mtR1, inc2), Cells(mtR2, inc2))
'Passage des valeurs en Copy
'Tout le code de la procédure relatif à la copie est commenté
'mtCopie.Copy
'Passage des valeurs dans un Array
ReDim array_copy(1 To mtNbR, 1 To 1)
array_copy() = mtCopie.Value
'+++TRANSFERT++++++++++++++
If x <= valTrim Then
Select Case code
Case "CC"
'Cells(mtR1, 16).Activate
Range(Cells(mtR1, 16), Cells(mtR1 + UBound(array_copy) - 1, 16)).Value = array_copy
Case "MC"
'Cells(mtR1, 17).Activate
Range(Cells(mtR1, 17), Cells(mtR1 + UBound(array_copy) - 1, 17)).Value = array_copy
Case "TP"
'Cells(mtR1, 18).Activate
Range(Cells(mtR1, 18), Cells(mtR1 + UBound(array_copy) - 1, 18)).Value = array_copy
Case "MO"
'Cells(mtR1, 19).Activate
Range(Cells(mtR1, 19), Cells(mtR1 + UBound(array_copy) - 1, 19)).Value = array_copy
End Select
'ActiveSheet.Paste
End If
'+++TRANSFERT++++++++++++++
If x > valTrim Then
Select Case code
Case "CC"
Range(Cells(mtR1, 20), Cells(mtR1 + UBound(array_copy) - 1, 20)).Value = array_copy
'Cells(mtR1, 20).Activate
Case "MC"
Range(Cells(mtR1, 21), Cells(mtR1 + UBound(array_copy) - 1, 21)).Value = array_copy
'Cells(mtR1, 21).Activate
Case "TP"
Range(Cells(mtR1, 22), Cells(mtR1 + UBound(array_copy) - 1, 22)).Value = array_copy
'Cells(mtR1, 22).Activate
Case "MO"
Range(Cells(mtR1, 23), Cells(mtR1 + UBound(array_copy) - 1, 23)).Value = array_copy
'Cells(mtR1, 23).Activate
End Select
'ActiveSheet.Paste
End If
Next
End If
Next
Application.ScreenUpdating = True
Range("C30").Value = Format(Timer - StartTime1, "00.00") & " secondes"
'Le résultat :
'==> 15,50 SECONDES EN MODE COPIE
'==> 00,16 CENTIEMES AVEC LES ARRAY!!!
'Comme quoi, ça vaut le coup de s'y pencher un peu ;-)
End Sub