Incrémentation automatique de N°

Version imprimable

21/02/2014, 13h11
MARGAR

1 pièce(s) jointe(s)

Incrémentation automatique de N°

Bonjour le forum,

Je suis entrain manuellement de recopier des N° dans une ligne (B25) et j'aimerais si cela est possible de le
faire automatiquement.
Ci-joint un petit fichier d'explication.

Cordialement et merci

margar
23/02/2014, 08h52
rjamin

Bonjour,
Une proposition à tester.
On inscrit un nombre en B25 puis click sur le bouton.

On peut vérifier toute les lignes du tableau en une seule opération également
Voir fichier si on ne vérifie qu'une ligne à la fois il suffit de na laissé qu'un n° à la ligne 25 et effacer tous les autres

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
24
25
26
27
28
29
30
31
32
33
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
If Target.Address = Range("b25").Address Then
    With Range("b2:r21")
 
    Set c = .Find(Target.Value, LookIn:=xlFormulas, LookAt _
    :=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase _
    :=True)
        If Not c Is Nothing Then
        firstAddress = c.Address
        Do
 
'    If c.Interior.ColorIndex = [c5].Interior.ColorIndex Then
'    r = -1
'    Else
'    r = 1
'    End If
 
        Cells(Target.Row, 3 + p) = c.Offset(0, 1).Value
        Cells(Target.Row, 4 + p) = c.Offset(0, 2).Value
 
        Cells(Target.Row, 12 + a) = c.Offset(r, 0).Value
        Cells(Target.Row, 13 + a) = c.Offset(r, 1).Value
        Cells(Target.Row, 14 + a) = c.Offset(r, 2).Value
 
        Set c = .FindNext(c)
        p = p + 2
        a = a + 3
        Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
    End With
End If
End Sub

Mais les adversaire de 2 du tour 3 etant placé en dessous, il reste un souci.

24/02/2014, 16h08
MARGAR

Incrémentation auto de N°

Bonjour rjamin, keygen08, le forum

@rjamin,
ta 2ème solution me convient parfaitement, MERCI

@keygen08,
merci aussi pour ta réponse

Cordialement

Margar