Macro de de multiplication

**mr big** · 08/12/2012, 19h58

bonjour,

j'ai trouvé sur le net une macro de démultiplication de ligne fort utile dans mon boulot dont voici le code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub Copie()
 
1: Dim k As Integer, m As Long, Derlign As Long, Nbre As Integer
 
2: Application.ScreenUpdating = False
3: For m = 2 To Range("A65536").End(xlUp).Row
4:  Derlign = Sheets("pondération surface").Range("A65536").End(xlUp).Row
5:  Nbre = Range("K" & m)
6:  Range("A" & m & ":y" & m).Copy Sheets("pondération surface").Range("A" & Derlign + 1 & ":y" & Derlign + 1 + Nbre - 1)
7:     For k = 1 To Nbre
8:       Sheets("pondération surface").Range("K" & Derlign + 1) = k
9:       Derlign = Derlign + 1
10:    Next k
11: Next m
12: Application.ScreenUpdating = True
 
End Sub

elle multiplie donc l’intégralité de la ligne par le nombre présent dans la cellule ( ds l'exemple, colonne K ).

Or, j'aurais besoin d'une évolution de cette macro a savoir que je dois rajouter des colonnes présentant les mois de l'année après ( jusqu’à y), et dans ces colonnes, un chiffre.
SI je lance la macro, elle multiplie la ligne mais également le chiffre qui est dans la colonne du mois ce qui ne me convient pas.
je souhaiterais juste que si j'ai 3 lignes qui se multiplie, j'ai 1 chiffre qui soit en janvier, 1 en mars et 1 en novembre par exemple.( dans le cas présent, j'ai 3 chiffres en janvier, 3 en mars, et 3 en novembre )

je sais pas si c'est clair ce que je raconte

, je met en CJ le fichier en question ,la macro est ci dessus.

Si vous pouviez m'aider, vous m’enlèveriez une grosse épine du pied, et des heures de boulots le WE

merci par avance.

**mercatog** · 08/12/2012, 21h28

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
32
33
34
35
36
37
38
39
40
41
42
43
44
Sub Copie()
Dim Ws As Worksheet
Dim LastLig As Long, i As Long, n As Long, m As Long
Dim Nb As Integer, k As Integer, ki As Integer
Dim j As Byte
Dim DATA, RES()
 
Application.ScreenUpdating = False
With Worksheets("Données teruti")
    LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row
    DATA = .Range("A2:Y" & LastLig)
End With
 
n = UBound(DATA, 1)
For i = 1 To n
    Nb = Val(DATA(i, 11))
 
    If i = 1 Then
        ReDim RES(1 To 25, 1 To Nb)
    Else
        m = UBound(RES, 2)
        ReDim Preserve RES(1 To 25, 1 To m + Nb)
    End If
 
    For k = 1 To Nb
        For j = 1 To 25
            If j < 14 Then
                RES(j, m + k) = DATA(i, j)
            Else
                If DATA(i, j) <> "" Then
                    RES(j, m + k) = DATA(i, j)
                    DATA(i, j) = ""
                    Exit For
                End If
            End If
        Next j
    Next k
Next i
 
With Worksheets("pondération surface")
    LastLig = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Range("A" & LastLig + 1).Resize(UBound(RES, 2), 25) = Application.Transpose(RES)
End With
End Sub