[XL-2019] Remplir et Transférer Un Tableau Excel VBA

Remplir et Transférer Un Tableau Excel VBA

Bonjour
Voici mon code Suivant qui me permettre de remplir un tableau a partir de la plage suivante B2:B14 et le transférer ver une autre plage

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Option Explicit
Sub Rempli_Trans()
    Dim Lrow As Integer
    Dim i As Integer
    Dim Tabl() As Currency
    Lrow = Range("F100000").End(xlUp).Row + 1
 
    'Remplissage tableau avec la plage de cellules B2:B14
    ReDim Tabl(1 To 13)
    For i = 1 To UBound(Tabl())
        Tabl(i) = Cells(i + 1, 2)
    Next i
    Range("F" & Lrow & ":R" & Lrow).Value = Tabl
    Range("B8").Value = Range("R" & Lrow).Value
End Sub

Apres j'ai remplacer la plage B2:B14 par une autre plage
et voici mon nouveau code

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Sub Rempli_Trans()
    Dim Lrow As Integer
    Dim i As Integer
    Dim Tabl(14) As Currency
    Lrow = Range("F100000").End(xlUp).Row + 1
 
    'Remplissage tableau avec la plage de cellules B2........................D14
    Tabl(0) = Range("B2").Value
    Tabl(1) = Range("B3").Value
    Tabl(2) = Range("B8").Value
    Tabl(3) = Range("B9").Value
    Tabl(4) = Range("B14").Value
    Tabl(5) = Range("C3").Value
    Tabl(6) = Range("C5").Value
    Tabl(7) = Range("C8").Value
    Tabl(8) = Range("C11").Value
    Tabl(9) = Range("C14").Value
    Tabl(10) = Range("D2").Value
    Tabl(11) = Range("D6").Value
    Tabl(12) = Range("D8").Value
    Tabl(13) = Range("D12").Value
    Tabl(14) = Range("D14").Value
    Range("F" & Lrow & ":T" & Lrow).Value = Tabl
    Range("B8").Value = Range("J" & Lrow).Value
End Sub

Si ma plage contient 50 cellules donc je doit écrire 50 ligne pour remplir mon tableau j'ai penser de nommer ma plage et la injecter dans le tableau mais je ne sais pas comment le faire
SVP est ce qu'il y a une solution pour diminuer ces lignes
merci

Citation:

Envoyé par iliesss

Bonjour,

A tester :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
 
Sub Rempli_Trans()
 
Dim Lrow As Long, I As Long
Dim GroupeB As Variant, GroupeC As Variant, GroupeD As Variant
 
    With ActiveSheet
 
         GroupeB = Array(2, 3, 8, 9, 14)
         GroupeC = Array(3, 5, 8, 11, 14)
         GroupeD = Array(2, 6, 8, 12, 14)
 
         Lrow = .Range("F100000").End(xlUp).Row + 1
 
         For I = LBound(GroupeB) To UBound(GroupeB)
             .Cells(Lrow, 6 + I) = .Cells(GroupeB(I), "B")
         Next I
 
         For I = LBound(GroupeC) To UBound(GroupeC)
             .Cells(Lrow, 11 + I) = .Cells(GroupeC(I), "C")
         Next I
 
         For I = LBound(GroupeD) To UBound(GroupeD)
             .Cells(Lrow, 16 + I) = .Cells(GroupeD(I), "D")
         Next I
 
        ' .Range("B8") = .Range("J" & Lrow)
 
    End With
 
End Sub

Bonjour Mr Eric
Merci beaucoup , très bonne solution ça marche très très bien.