Incrémenter code alpha numérique automatique

Version imprimable

2 pièce(s) jointe(s)

Bonjour à tous. Je suis débutant en VBA.
Je vous envoie un fragment de fichier de planification pour lequel je voudrais mettre le code des tâches (colonne A) sous les lignes de façon automatique car le fichier réel renferme un nombre important de lignes similaires.
Les tâches sont identifiées par les lignes dont la colonne C est vide
J'ai imaginé l'algorithme suivant:
Si la cellule CX est non vide copy la cellule AX de la même ligne et colle dans AX+1 et concaténer avec ".1"
Incrémente ensuite .2; .3; ... tant que la cellule "C" de la même ligne est vide, jusqu'à rencontrer une cellule non vide de la colonne A
Si tu rencontres une cellule non vide dans la colonne A, Copie la cellule; décale d'une ligne vers le bas, Colle et concaténer avec ".1"
Incrémente ensuite .2; .3 .... tant que la cellule "C" de la même ligne est vide, jusqu'à rencontrer une cellule non vide de la colonne A

Arrête lorsque tu rencontres la cellule qui contient "Total" .

J'ai joint le fichier initial (fichier planning) et le résultat que je souhaite avoir( fichier résultat)
J'ai commencé ceci mais la phase pour incrémenter m'est difficile car je ne sais pas indiquer comment s'arrêter si la cellule n'est pas vide et reprendre.
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 incrémentercode() Sheets (feuil1).Select Dim i As Integer Do While Not IsEmpty(Cells(i, 3)) Cells(i, 1).Select Selection.Copy ActiveCell.Offset(1, 0).Select Cells(i + 1, 1).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Cells(i + 1, 1) = Cells(i + 1, 1) & ".1" Loop Do While IsEmpty (Cells(i, 3)) Cells(i, 1).Select Selection.Copy ActiveCell.Offset(1, 0).Select Loop End Sub
Si quelqu'un peut m'aider je suis preneur. Merci d'avance.

Bonjour,

Une façon de faire cela:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Option Explicit
 
Sub Incrementer()
   Dim kR As Long, sCode As String, k As Long
   kR = 1                           '--- n° ligne
   While Cells(kR, 2) <> ""         '--- tant qu'il y a quelque chose en cellule de colonne 2 = B
      If Cells(kR, 1) > "" Then
         '--- cellule en colonne 1 = A n'est pas vide >>> réinitialise
         k = 0
         sCode = Cells(kR, 1)
      Else
         '--- cellule en colonne 1 = A est vide >>> incrémente
         k = k + 1
         Cells(kR, 1) = sCode & "." & k
      End If
      kR = kR + 1
   Wend
End Sub

Bonne continuation.

13/03/2019, 09h57
charben

Re Code Alpha numérique

Merci beaucoup pour l'appui M.EricDgn.
J'ai essayé mais, je ne vois que la première ligne générée.
Peux tu m'aider davantage?
13/03/2019, 10h17
EricDgn

Bonjour,
Chez moi cela fonctionne avec le fichier exemple attaché au premier message.
Bien comprendre que c'est la colonne B qui détermine quand le calcul s'arrête: cellule vide => fin
Enfin, un fichier contenant des macros doit être sauvé sous le format .xlsm
Cordialement
13/03/2019, 10h26
MarcelG

Bonjour et bienvenu sur ce Forum,

Pas de fichier joint lors du 1er post. C'est une règle.

3 remarques
- la variable i n'est ni initialisée, ni alimentée (aucune incrémentation)
- Ces f... Select ne servent à rien
- les objets Cells ne sont pas rattachés à la feuille Parent

Quant au code.
Eviter ce genre de ligne

Code:

Do While Not IsEmpty(Cells(i, 3))

Balayer plutôt les Cellules Spéciales vides ou avec constante.