Réaliser un tableau via vba

michaelexcel

XLDnaute Nouveau
Bonjour à tous,

J'ai deux petits défis pour les programmateur VBA... (et un défi impossible pour moi..) Vous trouverez ci-joint un fichier simplifié.

Défi 1 :
Le tableau "to-do list" reprend les sous-tâches d'un projet sélectionné en C1. On trouve à côté de chaque ligne une flèche à laquelle j'aimerai affecter une macro. Cette macro ajoutera dans le tableau "A faire aujourd'hui" la sous-tâche correspondante.

Défi 2 :
A côté de chaque ligne du tableau "A faire aujourd'hui", on trouve un cercle barré auquel j'aimerai affecter une autre macro. Celle-ci retirerai la sous-tâche de la ligne en réorganisant le tableau pour qu'il n'y est pas de trous..

Cela vous parait-il faisable?

D'avance merci !!
 

Fichiers joints

job75

XLDnaute Barbatruc
Bonjour michaelexcel,

Pour "Défi 1" :
Cette macro ajoutera dans le tableau "A faire aujourd'hui" la sous-tâche correspondante.
On la trouve où cette "sous-tâche correspondante" ?

Et pour "Defi 2" :
Celle-ci retirerai la sous-tâche de la ligne en réorganisant le tableau pour qu'il n'y est pas de trous..
Alors les sous-tâches ne seront plus en face de leurs tâches ??!!

A+
 

michaelexcel

XLDnaute Nouveau
Bonjour,

Je n'ai pas été assez clair, le terme "sous-tâche" induit en erreur. Voici l'objectif de ce tableau pour mieux comprendre.

Défi 1 :
1) Je sélectionne un projet en C1:D1. Les tâches correspondantes s'affichent en B4:B9 (jusque là ça marche déjà)

2) Je souhaite par exemple réaliser aujourd'hui la tâche "organiser une conférence" inscrite en B4. En appuyant sur la flèche en C4, j'aimerai que "organiser une conférence" s'ajoute au tableau "à faire aujourd'hui" en D4:D10.

3) Je continue à parcourir tous les projets et ajoute ainsi au fur et à mesure tout ce que je planifie de faire aujourd'hui.

Défi 2

1) Je change d'avis sur une tâche située dans le tableau "A faire aujourd'hui". Je clique sur la croix à côté et la case s'efface. Mais le tableau se réorganise pour ne pas laisser de trous.

Le fait que les deux tableaux soient en face n'a pas d'importance en fait. Ils pourraient être sur deux feuilles différentes...

Merci beaucoup !!!
 

job75

XLDnaute Barbatruc
Bonsoir,

Ces 2 macros sont à placer dans le code de la feuille "Travail" :
Code:
Sub Ajouter()
With Me.Shapes(Application.Caller).TopLeftCell.Offset(, -1)
  If .Value <> 0 Then Range("D" & Rows.Count).End(xlUp)(2) = .Value
End With
End Sub

Sub Supprimer()
Dim t, i&, n&
Me.Shapes(Application.Caller).TopLeftCell.Offset(, -1) = ""
With Range("D3", Range("D" & Rows.Count).End(xlUp))
  t = .Resize(, 2) 'au moins 2 éléments
  For i = 1 To UBound(t)
    If t(i, 1) <> "" Then
      n = n + 1
      t(n, 1) = t(i, 1)
      If i > n Then t(i, 1) = ""
    End If
  Next
  .Value = t
End With
End Sub
La 1ère macro est à affecter à chaque flèche, la 2ème à chaque cercle.

Nota : j'ai renommé les cercles, les noms étaient trop longs...

Fichier joint.

Bonne nuit.
 

Fichiers joints

job75

XLDnaute Barbatruc
Bonjour michaelexcel,

Les flèches et les cercles ne sont guère utiles (ils sont même nuisibles en grand nombre) :
Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("B4:B" & Rows.Count)) Is Nothing Then
  If Target <> 0 Then Range("D" & Rows.Count).End(xlUp)(2) = Target
ElseIf Not Intersect(Target, Range("D4:D" & Rows.Count)) Is Nothing Then
  Dim t, i&, n&
  [D3].Select
  Target = ""
  With Range("D3", Range("D" & Rows.Count).End(xlUp))
    t = .Resize(, 2) 'au moins 2 éléments
    For i = 1 To UBound(t)
      If t(i, 1) <> "" Then
        n = n + 1
        t(n, 1) = t(i, 1)
        If i > n Then t(i, 1) = ""
      End If
    Next
    .Value = t
  End With
End If
End Sub
Fichier (2).

A+
 

Fichiers joints

job75

XLDnaute Barbatruc
Bonjour michaelexcel, le forum,

Le 2ème tableau peut être formaté en fonction du nombre de lignes :
Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Or Target(1) = 0 Then Exit Sub
If Not Intersect(Target, Range("B4:B" & Rows.Count)) Is Nothing Then
  With Range("D" & Rows.Count).End(xlUp)(2)
    .Value = Target
    .Borders.Weight = xlMedium
    If .Row > 4 Then .Borders(xlEdgeTop).LineStyle = xlNone
    .Interior.Color = IIf(.Row Mod 2, 14083324, 15921906)
  End With
ElseIf Not Intersect(Target, Range("D4:D" & Rows.Count)) Is Nothing Then
  Dim t, i&, n&
  [D3].Select
  Target = ""
  With Range("D3", Range("D" & Rows.Count).End(xlUp))
    t = .Resize(, 2) 'au moins 2 éléments
    For i = 1 To UBound(t)
      If t(i, 1) <> "" Then
        n = n + 1
        t(n, 1) = t(i, 1)
        If i > n Then t(i, 1) = ""
      End If
    Next
    .Value = t
    With .Cells(n + 1)
      .Borders.LineStyle = xlNone
      .Cells(0).Borders(xlEdgeBottom).Weight = xlMedium
      .Interior.ColorIndex = xlNone
    End With
  End With
End If
End Sub
Fichier (3).

Bonne journée.
 

Fichiers joints

michaelexcel

XLDnaute Nouveau
Wooooo !!

Ca va plus loin que je n'imaginais. Merci beaucoup...

J'aimerai beaucoup apprendre comment ces codes fonctionnent. Je suis autodidacte et je découvre petit à petit toutes les possibilités qu'offre excel... Pourrais-tu m'expliquer les différents éléments du code? En tout cas, au moins le test 1 (qui me semble le plus simple des trois...).

D'avance merci si tu as le temps !
 

michaelexcel

XLDnaute Nouveau
Chouette merci.. Je vais demander juste pour le test 1. Sinon ça va faire beaucoup de question....

Pour la sub Ajouter()
With Me.Shapes(Application.Caller).TopLeftCell.Offset(, -1)
If .Value <> 0 Then Range("D" & Rows.Count).End(xlUp)(2) = .Value

1) Comment la ligne est-elle sélectionnée par rapport à la flèche? A quel endroit du code est-ce que ça passe?

2) .End(xlUp)(2)
Qu'est-ce que ça signifie?

Sub Supprimer()

3) Me.Shapes(Application.Caller).TopLeftCell.Offset(, -1) = ""
Là il n'y a pas un seul élément que je comprends..

4) For i = 1 To UBound(t)
UBound ?
 

job75

XLDnaute Barbatruc
Bonjour michaelexcel, le forum,

1) Application.Caller renvoie le nom de la Shape qui a déclenché la macro.

La propriété TopLeftCell détermine la cellule où se trouve cette Shape.

La fonction Offset(, -1) détermine la cellule à gauche de la précédente.

2) End(xlUp) détermine la 1ère cellule non vide en remontant.

End(xlUp)(2) détermine la cellule (vide) située dessous.

4) Ubound(t) renvoie la 1ère dimension (hauteur) du tableau t.

Pour plus d'informations faites une recherche sur le web de ce qui est en rouge.

Bonne journée.
 

job75

XLDnaute Barbatruc
Re,

Avec cette macro le 1er tableau est entièrement recréé :
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [Choix]) Is Nothing Then Exit Sub
Dim c As Range, n&, i&, j&
Application.ScreenUpdating = False
Set c = [DebTab1] 'en-tête du 1er tableau
c(2, 0).Resize(Rows.Count - c.Row, 2).Delete xlUp 'RAZ
If [Choix] = "" Then Exit Sub
n = Application.Match([Choix], [Projet], 0) 'plage nommée "Projet"
With Feuil2 'CodeName
  For i = 2 To .Range("D" & .Rows.Count).End(xlUp).Row
    If Int(Val(.Cells(i, 4))) = n And .Cells(i, 5) <> "" Then
      j = j + 1
      c(j + 1, 0).Resize(, 2) = .Cells(i, 4).Resize(, 2).Value
      c(j + 1, 1).Interior.Color = IIf(j Mod 2, 15917529, 15921906)
    End If
  Next
End With
For i = 7 To 10
  If j Then c(2).Resize(j).Borders(i).Weight = xlMedium
Next
End Sub
J'ai nommé les cellules C1 B3 D3 ce qui permet d'insérer des lignes ou colonnes comme on veut.

La nom défini Projet est créé par cette macro dans la 2ème feuille :
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
With Range("B" & Rows.Count).End(xlUp)
  Range("B2", IIf(.Row = 1, "B2", .Cells)).Name = "Projet" 'plage nommée
End With
End Sub
Fichier (4).

A+
 

Fichiers joints

Discussions similaires


Haut Bas