Discussion :

[aslefebvre]

Bonjour à tous!

Je me présente: Niveau 0 en VBA
Etudiante en logistique en contrat pro
Dans le cadre de mon projet en entreprise on m'a sollicité pour créer un tableau simple en apparence ...
La difficulté de ce tableau réside dans le fait que la saisie doit être automatique ...je m'explique :

1/ je dispose d'un ordre bien précis de données comme suit:

• A1
• A8
• A22
• A4
• A6
• A18
• A30

2/ Je dois créer un tableau qui en entrant la données de la première cellule me donne automatiquement les données pour le reste de la colonne.
Exemple: en cellule 1 je renseigne A6 l’ordre des cellules est alors :

• A6
• A18
• A30
• A1
• A8
• A22
• A4

Ma question est la suivante :
Existe-t-il un moyen de programmer cela sur Excel et si oui …y-a-t-il une âme charitable pour m’aider sur cette partie de mon projet ?

Merci par avance d’avoir lu ce « pavé » !

[casefayere]

Bonjour, ci-dessous le code pour le fichier joint, donc à adapter

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
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Tbdonnees, TbResultat(), y As Long
Dim Dc As Range, x As Long, tr As Range
y = 1
If Target.Address = "$B$2" Then
  Set Dc = Range("A" & Rows.Count).End(xlUp)
  Tbdonnees = Range("A2", Dc)
  ReDim tbresult(1 To UBound(Tbdonnees))
  Set tr = Range("A1", Dc).Find(Target.Value)
  If Not tr Is Nothing Then
    For x = tr.Row - 1 To UBound(Tbdonnees)
      tbresult(y) = Tbdonnees(x, 1)
      y = y + 1
    Next x
    For x = 1 To tr.Row - 2
      tbresult(y) = Tbdonnees(x, 1)
      y = y + 1
    Next x
  End If
  Range("B2").Resize(UBound(tbresult)) = Application.Transpose(tbresult)
End If
End Sub

[aslefebvre]

Un énorme merci à vous!

Je vais tenter ce que vous m'avez conseillé!

Merci pour votre réactivité

[casefayere]

Je me présente: Niveau 0 en VBA

Afin de pouvoir adapter, je remets le code avec ses explications

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
Private Sub Worksheet_Change(ByVal Target As Range) 'donc dans l'évènement "Change" de la feuille
'on déclare les variables
Dim Tbdonnees, TbResultat(), y As Long
Dim Dc As Range, x As Long, tr As Range
y = 1 'on donne la valeur 1 à la variable y
If Target.Address = "$B$2" Then 'si la valeur est entrée en B2
  Set Dc = Range("A" & Rows.Count).End(xlUp) 'Dc = dernière cellule utilisée en col A
  Tbdonnees = Range("A2", Dc) 'on remplit le tableau avec les valeurs de la col A
  ReDim tbresult(1 To UBound(Tbdonnees)) 'on redimensionne le tableau qui recevra les données
  Set tr = Range("A1", Dc).Find(Target.Value) 'on cherche la valeur de B2 dans la col A
  If Not tr Is Nothing Then 'si aucune erreur on continue
    For x = tr.Row - 1 To UBound(Tbdonnees) 'on boucle à partir de la position de la _
    valeur en A jusqu'à la fin du tableau et on donne les valeurs restantes au resultat
      tbresult(y) = Tbdonnees(x, 1)
      y = y + 1
    Next x
    'ci-dessous, une nouvelle boucle pour reprendre les autres valeurs
    For x = 1 To tr.Row - 2
      tbresult(y) = Tbdonnees(x, 1)
      y = y + 1
    Next x
  End If
  'ci-dessous, on rend le resultat à la colonne B
  Range("B2").Resize(UBound(tbresult)) = Application.Transpose(tbresult)
End If
End Sub

Ne pas oublier de cliquer sur si c'est le cas

[aslefebvre]

Merci infiniment!

Avec les explications c 'est génial, je suis entrain d'essayer d'adapter tout ceci au format final de mon tableau .
Je vous tiens au courant.

[aslefebvre]

Youpi ça marche nickel!!!

J'ai pu grâces à vos explications adapter cela à mes données .

Juste une petite interrogation demeure: si je souhaite sur la meme feuille excel et de manière complètement indépendante des premiers résultats insérer un autre listing automatisé quel serait la procédure sur VBA (encore désolé de mon ignorance totale )?

[casefayere]

Tu verras dans ce code une légère variante, on cherche la valeur dans le tableau mais plus avec "Find", de plus je ne tiens plus compte des majuscules/minuscules

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
Private Sub Worksheet_Change(ByVal Target As Range) 'donc dans l'évènement "Change" de la feuille
'on déclare les variables
Dim Tbdonnees, TbResultat(), y As Long
Dim Dc As Range, x As Long, Tr As Long 'Tr deviens "Long" et non "Range"
Tr = 0
y = 1 'on donne la valeur 1 à la variable y
If Target.Address = "$B$2" Then 'si la valeur est entrée en B2
  Set Dc = Range("A" & Rows.Count).End(xlUp) 'Dc = dernière cellule utilisée en col A
  Tbdonnees = Range("A2", Dc) 'on remplit le tableau avec les valeurs de la col A
  ReDim tbresult(1 To UBound(Tbdonnees)) 'on redimensionne le tableau qui recevra les données
  'ci-dessous autre façon de trouver la valeur dans le tableau
  For x = 1 To UBound(Tbdonnees)
    'ci-dessous, j'ajoute "Ucase" pour ne pas tenir compte des majuscules/minuscules
    If UCase(Tbdonnees(x, 1)) = UCase(Target.Value) Then Tr = x: Exit For
  Next x
  If Tr > 0 Then 'si aucune erreur on continue
    For x = Tr To UBound(Tbdonnees) 'on boucle à partir de la position de la _
    valeur en A jusqu'à la fin du tableau et on donne les valeurs restantes au resultat
      tbresult(y) = Tbdonnees(x, 1)
      y = y + 1
    Next x
    'ci-dessous, une nouvelle boucle pour reprendre les autres valeurs
    For x = 1 To Tr - 1
      tbresult(y) = Tbdonnees(x, 1)
      y = y + 1
    Next x
  Else
    MsgBox "aucune donnée ne correspond"
  End If
  'ci-dessous, on rend le resultat à la colonne B
  Range("B2").Resize(UBound(tbresult)) = Application.Transpose(tbresult)
End If
End Sub

[casefayere]

Dans le même évènement, changer l'adresse de cette ligne de code (condition)

Code :

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

If Target.Address = "$B$2" Then

et rédiger la procédure, toujours dans l'évènement

Code :

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

Private Sub Worksheet_Change(ByVal Target As Range)

suivant ce que tu veux faire, peut-être auras-tu besoin d'appliquer ces lignes en début et fin de procédure

Code :

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

1
2
3
Application.EnableEvents = False
'.......
Application.EnableEvents = True

A voir !!!!

[aslefebvre]

Mince...j'ai tenté..c'est loupé!
J 'ai joins une partie des tableaux.

Je suis dans la mouise...

[casefayere]

il ne fallait pas t'embéter à changer les noms des variables, mets ce code à la place de l'autre, sinon as-tu regardé ma derniere proposition

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
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Tbdonnees, tbresult(), y As Long
Dim Dc As Range, x As Long, tr As Range
y = 1
If Target.Address = "$B$2" Then
  Set Dc = Range("A" & Rows.Count).End(xlUp)
  Tbdonnees = Range("A2", Dc)
  ReDim tbresult(1 To UBound(Tbdonnees))
  Set tr = Range("A1", Dc).Find(Target.Value)
  If Not tr Is Nothing Then
    For x = tr.Row - 1 To UBound(Tbdonnees)
      tbresult(y) = Tbdonnees(x, 1)
      y = y + 1
    Next x
    For x = 1 To tr.Row - 2
      tbresult(y) = Tbdonnees(x, 1)
      y = y + 1
    Next x
  End If
  Range("B2").Resize(UBound(tbresult)) = Application.Transpose(tbresult)
End If
y = 1
If Target.Address = "$E$2" Then
  Set Dc = Range("D" & Rows.Count).End(xlUp)
  Tbdonnees = Range("D2", Dc)
  ReDim tbresult(1 To UBound(Tbdonnees))
  Set tr = Range("D1", Dc).Find(Target.Value)
  If Not tr Is Nothing Then
    For x = tr.Row - 1 To UBound(Tbdonnees)
      tbresult(y) = Tbdonnees(x, 1)
      y = y + 1
    Next x
    For x = 1 To tr.Row - 2
      tbresult(y) = Tbdonnees(x, 1)
      y = y + 1
    Next x
  End If
  Range("E2").Resize(UBound(tbresult)) = Application.Transpose(tbresult)
End If
End Sub

[aslefebvre]

Super!
j'ai cru qu'il fallait tout adapter au final je n'ai guère contribué à ce tableau!
Merci pour le travail accomplie !

C 'est ma première discussion dans ce forum et permettez moi de vous dire que c'est génial autant d'attention et merci pour le temps que vous consacrés bénévolement .