Macro de de multiplication

Version imprimable

1 pièce(s) jointe(s)

bonjour,

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

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:aie:, 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 :mouarf::mouarf::mouarf:

merci par avance.

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
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

09/12/2012, 08h23
mr big

comment dire...

:merci: :merci: :merci:

ça marche, franchement, merci beaucoup ;)

PS : maintenant, je vais essayer de comprendre comment ça marche