Garnissage tableau en VBA

[eduraiss]

Bonjour le forum

Voila j'aimerais regrouper dans un seul tableau le nom des personne présentes

Je joint un fichier exemple

merci à vous

 

[job75]

Re : Garnissage tableau en VBA

Bonsoir eduraiss,

Voyez le fichier joint et cette macro dans la code de la feuille "COMPIL" :

Private Sub Worksheet_Activate()
Dim d As Object, w As Worksheet, c As Range, t$, n&, rest()
Set d = CreateObject("Scripting.Dictionary")
On Error Resume Next 'si une plage est vide
For Each w In Worksheets
  If w.Name <> "COMPIL" Then
    'modifier éventuellement la plage étudiée
    For Each c In w.[B4:H100].SpecialCells(xlCellTypeConstants, 2)
      t = Application.Trim(c) 'SUPPRESPACE
      If Not d.exists(t) Then
        n = n + 1
        d(t) = n
        ReDim Preserve rest(1 To 8, 1 To n) 'tableau transposé
        rest(1, n) = t
      End If
      rest(c.Column, d(t)) = t
    Next
  End If
Next
'---restitution et tri alphabétique sur colonne A auxiliaire---
Application.ScreenUpdating = False
Range("A3:H" & Rows.Count).Clear 'RAZ
[A3].Resize(n, 8) = Application.Transpose(rest)
[A3].Resize(n, 8).Sort [A3], xlAscending, Header:=xlNo
[A3].Resize(n) = ""
'---bordures et largeur des colonnes---
With [B3].Resize(n, 7)
  .Borders(xlEdgeLeft).Weight = xlMedium
  .Borders(xlEdgeRight).Weight = xlMedium
  .Borders(xlInsideVertical).Weight = xlMedium
  .Borders(xlEdgeBottom).Weight = xlThin
  .Borders(xlInsideHorizontal).Weight = xlThin
  .EntireColumn.AutoFit
End With
End Sub

Elle s'exécute quand on active la feuille.

Edit : il y avait un espace superflu sur ABDOU SALAMI, d'où Application.Trim.

A+

 

[job75]

Re : Garnissage tableau en VBA

Re,

En fait il est plus classique dans ce genre de problème de lister les noms et d'utiliser des "coches" :

Private Sub Worksheet_Activate()
Dim d As Object, w As Worksheet, c As Range, t$, n&, rest()
Set d = CreateObject("Scripting.Dictionary")
On Error Resume Next 'si une plage est vide
For Each w In Worksheets
  If w.Name <> "COMPIL" Then
    'modifier éventuellement la plage étudiée
    For Each c In w.[B4:H100].SpecialCells(xlCellTypeConstants, 2)
      t = Application.Trim(c) 'SUPPRESPACE
      If Not d.exists(t) Then
        n = n + 1
        d(t) = n
        ReDim Preserve rest(1 To 8, 1 To n) 'tableau transposé
        rest(1, n) = t
      End If
      rest(c.Column, d(t)) = "ü" 'coche
    Next
  End If
Next
'---restitution et tri alphabétique sur colonne A auxiliaire---
Application.ScreenUpdating = False
Range("A3:H" & Rows.Count).Clear 'RAZ
[A3].Resize(n, 8) = Application.Transpose(rest)
[A3].Resize(n, 8).Sort [A3], xlAscending, Header:=xlNo
'---formatage---
With [A3].Resize(n, 8)
  .Borders(xlEdgeLeft).Weight = xlMedium
  .Borders(xlEdgeRight).Weight = xlMedium
  .Borders(xlInsideVertical).Weight = xlMedium
  .Borders(xlEdgeBottom).Weight = xlThin
  .Borders(xlInsideHorizontal).Weight = xlThin
End With
[A2].Resize(n + 1).Columns.AutoFit
[B3].Resize(n, 7).Font.Name = "Wingdings"
[B3].Resize(n, 7).HorizontalAlignment = xlCenter
End Sub

Fichier (2).

A+

 

[job75]

Re : Garnissage tableau en VBA

Bonjour eduraiss, le forum,

Juste 2 remarques.

1) Si l'on écrit For Each c In w.[B4:H30000]...

on récupère des valeurs de la feuille "M2" dont on n'a que faire.

2) Si l'on efface tous les noms de la feuille "Z1B" (la 1ère) on récupère une ligne vide dans la feuille 'COMPIL".

Pour éviter cette ligne vide écrire If Not d.exists(t) And t <> "" Then

Bonne journée

 

[eduraiss]

Re : Garnissage tableau en VBA

Bonjour le forum
Bonjour job75 un grand merci c'est exactement ce qu'il me fallait, en plus la validation suivant le jour dans la semaine est nickel, cela permet une lecture plus directe
Bien cordialement

 

[eduraiss]

Re : Garnissage tableau en VBA

Bonjour le forum

Bonjour job75
Pour répondre clairement: oui, il peut y avoir une même personne le même jour sur deux feuilles différentes mais là c'est une erreur, la dite personne doit pas être la même journée sur deux feuilles différentes.

Donc plus clairement je voudrais juste que le code récupère la valeur de la celllule A2 à la place de la coche
Exemple : j'ai une feuille qui s'appelle Gontier en cellule A2 je rentrerais GO, le récupération de ce texte à la place de la cohe me permet de s'avoir que Monsieur X etait le mercredi chez Gontier

Merci à vous

 

[job75]

Re : Garnissage tableau en VBA

Bonjour eduraiss,

On peut mettre ce qu'on veut à la place des coches :

Private Sub Worksheet_Activate()
Dim d As Object, w As Worksheet, c As Range, t$, n&, rest()
Set d = CreateObject("Scripting.Dictionary")
On Error Resume Next 'si une plage est vide
For Each w In Worksheets
  If w.Name <> "COMPIL" Then
    'modifier éventuellement la plage étudiée
    For Each c In w.[B4:H100].SpecialCells(xlCellTypeConstants, 2)
      t = Application.Trim(c) 'SUPPRESPACE
      If Not d.exists(t) And t <> "" Then
        n = n + 1
        d(t) = n
        ReDim Preserve rest(1 To 8, 1 To n) 'tableau transposé
        rest(1, n) = t
      End If
      rest(c.Column, d(t)) = w.Name '= w.[A2]
    Next
  End If
Next
'---restitution, tri et formatage---
Application.ScreenUpdating = False
Range("A3:H" & Rows.Count).Delete xlUp 'RAZ
With [A3].Resize(n, 8)
  .Value = Application.Transpose(rest)
  .Sort [A3], xlAscending, Header:=xlNo
  '---bordures---
  .Borders(xlEdgeLeft).Weight = xlMedium
  .Borders(xlEdgeRight).Weight = xlMedium
  .Borders(xlInsideVertical).Weight = xlMedium
  .Borders(xlEdgeBottom).Weight = xlThin
  .Borders(xlInsideHorizontal).Weight = xlThin
End With
[A2].Resize(n + 1).Columns.AutoFit
End Sub

Fichier (3).

A+

 

[eduraiss]

Re : Garnissage tableau en VBA

Re

merci beaucoup soit nom de la feuille ou A2 c'est parfait
Un grand merci a vous
Cordialement,