Découpage si cellule >= 61

Version imprimable

Bonjour,

Actuellement j'essaie de faire cette macro :

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
Sub test()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
 
Dim c As Integer
 
For Each c In Range("F:F")
'en sachant que la valeur maximale de la cellule doit être 60
'donc
 
If c >= 61 And c <= 120 Then
'le découpage va se faire en 2
 
'1) inserer une ligne juste en dessous
'2) copier/coller toute la ligne c sur la ligne qui a été inserer
'3) si on a par exemple on a la valeur 70, ça sera 60 en première ligne, puis 10 en deuxième ligne
 
If c >= 121 Then
'le découpage va se faire en 3
 
If c >= 181 Then
'le découpage va se faire en 4
 
'et ainsi de suite
 
 
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Première question : comment faire ça ? (le fait que si on a par exemple 70, alors il met 60 en première ligne, et le reste (10) en deuxième ligne)

Deuxième question : peut-on faire plus simple que ce que j'ai fait ?

Merci par avance

Bonjour,

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub Test()
Dim LastLig As Long, i As Long
Dim nbLig As Byte, j As Integer
Application.ScreenUpdating = False
With Sheets("Feuil3")         'à adapter
    LastLig = .Cells(Rows.Count, "F").End(xlUp).Row
    For i = LastLig To 2 Step -1
        nbLig = (.Range("F" & i).Value - 1) \ 60
        If nbLig > 0 Then
            .Rows(i).Copy
            .Rows(i & ":" & i + nbLig - 1).Insert
            Application.CutCopyMode = False
            For j = 0 To nbLig
                If j = nbLig Then
                    .Range("F" & i + j).Value = .Range("F" & i + j).Value - 60 * nbLig
                Else
                    .Range("F" & i + j).Value = 60
                End If
             Next j
        End If
    Next i
End With
End Sub

Bonjour,

un essai

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub test()
Dim c As Range
Dim a
Dim b
 
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
 
 
    For Each c In Range("F:F")
        If c >= 61 Then
        a = c.Row
        b = c.Value
        Rows(a).Copy
        Rows(a).Insert shift:=xlDown
        c.Offset(-1) = 60
        c = b - 60
        End If
    Next c
 
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

10/06/2010, 13h33
wyzer

Merci à vous deux, ça fonctionne !!!!!:ccool: