Macro pour boulcer dans une liste pour faire des tableaux/onglets

truann01 · 6 Septembre 2013

Bonjour,

J'ai encore beaucoup de difficultés à m'y retrouver en vba et votre aide serait grandement appréciée. J'ai une liste pour laquelle je désire, à l'aide d'une marcro, créer automatiquement des onglets pour chacune des personnes et compléter le tableau avec les informations correspondantes. À toutes les fois que la liste sera regénérée, celle-ci contiendra à tout coup le même nombre de colonnes mais pas nécessairement le même nombre de lignes

Je ne sais pas si mon explicaton est claire?

Grosso-modo, voici à quoi ressemble ma liste (qui se trouve dans l'onglet «Données»)

Nom No Item Date
Stéphane 123 01/08/2013
Stéphane 456 05/08/2013
Stéphane 667 01/08/2013
Annie 355 09/09/2013
Annie 456 08/09/2013

Je voudrais avoir un onglet pour Stéphane et un onglet pour Annie (et toutes les autres personnes de la liste), puis sur chacun des onglets, je voudrais un tableau avec toutes les informations reliées à la personne.

Lorsqu'il s'agit de boucler en vba (et aures!) c'est un peu (et même beaucoup!) le néant.

Je joins mon fichier excel.

Un gros MERCI!

Annie

klin89 · 6 Septembre 2013

Re : Macro pour boulcer dans une liste pour faire des tableaux/onglets

Bonjour le forum,
Bonjour Annie,

Une demande similaire dans ce fil :
https://www.excel-downloads.com/threads/rangement-automatique-des-donnees-sur-autre-feuille.209863/

Klin89

Jack2 · 7 Septembre 2013

Re : Macro pour boulcer dans une liste pour faire des tableaux/onglets

Bonjour,

Ci-joint une macro qui semble marcher. Il y a certainement plus court.

http://cjoint.com/?0IhsVjYSDSO
Pour l'essayer, il faut cliquer sur le bouton commande ou F5 sur le module test.

A+

truann01 · 9 Septembre 2013

Re : Macro pour boulcer dans une liste pour faire des tableaux/onglets

Re-bonjour,

Merci pour les réponses

À toi Klin89 : J'ai effectivement regardé la demande qui était similaire à la mienne. Tu as raison, c'est bien ce je que souhaite faire. J'ai tenté d'appliquer le code à mon fichier.... mais je pense que je suis encore plus nulle que je pensais en vba. En fait comme je ne comprends pas vraiment le code et bien ça ne fonctionne pas! ;-(

Jack2 : Je n'arrive pas à ouvrir le lien. Le site doit être bloqué par notre administrateur.

J'ai quand même tenté de faire un essai par moi-même en prenant un petit bout de code et ... ça fonctionne, mais à moitié! Je suis quand même fière de moi ;-)

En fait, j'arrive à créer mes onglets selon la feuille modèle, mais il ne copie que la première ligne de la personne. Il faudrait que j'ajoute une boucle pour lui indiquer que tant et aussi longtemps que c'est la même personne dans la colonne nom, copier les informations qui s'appliquent dans le tableau.

C'est le petit bout qui me manque. Quelqu'un peut-il m'aider svp?

Voici mon nouveau fichier

Merci encore pour votre aide

Annie

Jack2 · 9 Septembre 2013

Re : Macro pour boulcer dans une liste pour faire des tableaux/onglets

Bonjour le Forum, Bonjour truann01,

Ci-après le code

Code:

Function FeuilleExiste(wk As Workbook, stFeuille) As Boolean
    On Error Resume Next
    FeuilleExiste = Not (wk.Sheets(stFeuille) Is Nothing)
End Function


'compte le nombre de lignes de données par prénom
Function Nbre_Ligne_Nom(Onglet As String, Compt As Integer) As Integer
Dim St As String
St = Sheets("Données").Range("A" & Compt).Value
    
While St = Onglet
    Compt = Compt + 1
    St = Sheets("Données").Range("A" & Compt).Value
Wend
Nbre_Ligne_Nom = Compt - 1
End Function



Sub Traite_Donnée(Onglet As String, Compt As Integer)
Dim Fin As Integer, Debut As Integer

Sheets(Onglet).Activate

Range("A2").Value = Sheets("Données").Range("B" & Compt).Value
Range("A2").Font.Bold = True
Range("A3").Value = Sheets("Données").Range("C" & Compt).Value
Range("A5").Value = Sheets("Données").Range("A" & Compt).Value
Range("A5").Font.Bold = True

Sheets("Données").Activate
Range("D1:M1").Select
Application.CutCopyMode = False
Selection.Copy
Sheets(Onglet).Activate
Range("A6").Select
ActiveSheet.Paste
Selection.Font.Bold = True
Selection.Interior.ColorIndex = 46

'première ligne pour un prénom 
Debut = Compt 
'dernière ligne pour un prénom 
Fin = Nbre_Ligne_Nom(Onglet, Compt)
'Copier coller de données vers les autres feuilles
Sheets("Données").Activate
Range("D" & Debut & ":M" & Fin).Select
Selection.Copy
Sheets(Onglet).Activate
Range("A7").Select
ActiveSheet.Paste
Range("A1").Select

End Sub


Public Sub Test()
Dim Onglet As String
Dim Compt As Integer
   
'boucle sur les prénoms
Compt = 2
Onglet = Sheets("Données").Range("A" & Compt).Value
While Onglet <> ""
    If Not FeuilleExiste(ThisWorkbook, Onglet) Then
        Worksheets.Add.Name = Onglet
        Sheets(Onglet).Move After:=Sheets(Sheets.Count)
        Call Traite_Donnée(Onglet, Compt)
    End If
    Onglet = Sheets("Données").Range("A" & Compt).Value
Wend
End Sub

Comme je débute aussi, je vais regarder ton code. Si je le comprends, j'essaierai de l'adapter pour que toutes les informations par prénom soient copiées.

A+

Jack2 · 10 Septembre 2013

Re : Macro pour boulcer dans une liste pour faire des tableaux/onglets

Suite,

Une compil des deux (plus courte grâce à Max = Range("A" & Rows.Count).End(xlUp).Row) et la feuille Modèle :

Code:

Sub CreationOnglet()
Dim O As Integer
Dim Max As Integer
Dim Ws As Worksheet
Dim Debut As Integer, Fin As Integer
Dim Onglet As String


Application.ScreenUpdating = False
Set Ws = Sheets("Données")
Sheets("Données").Activate
Max = Range("A" & Rows.Count).End(xlUp).Row

For O = 2 To Max
    If Not ExisteFeuille(Ws.Range("A" & O).Text) Then
      Sheets.Add after:=Sheets(Sheets.Count)
      Onglet = Ws.Range("A" & O)
      ActiveSheet.Name = Onglet
      Sheets("Modèle").Cells.Copy Destination:=Range("A1")
      Range("A5") = Ws.Range("A" & O)
      Range("A2") = Ws.Range("B" & O)
      Range("A3") = Ws.Range("C" & O)
    
      Debut = O
      Fin = Nbre_Ligne_Nom(Onglet, Debut)

      Sheets("Données").Activate
      Range("D" & Debut & ":M" & Fin).Select
      Selection.Copy
      Sheets(Onglet).Activate
      Range("A7").Select
      ActiveSheet.Paste
      Range("A1").Select
   End If
Next O
Ws.Select
Application.ScreenUpdating = True
End Sub

Si on peut faire plus court...
A+

truann01 · 10 Septembre 2013

Re : Macro pour boulcer dans une liste pour faire des tableaux/onglets

Bonjour Forum, bonjour Jack2,

J'ai essayé ton modèle plus court mais il y a quelque chose qui cloche... En fait on y est presque! Le code fait la création des onglets, utilise le modèle (super, yes!), là où ça fonctionne moins bien, c'est qu'il complète le tableau par prénom avec 2 lignes à tout coup (sauf pour Josée qui en a une seule) et dont une des deux lignes n'appartenant pas à la personne.

Ex.
Pour l'onglet Stéphane : le code a copié la dernière ligne de Stéphane et la première ligne d'Annie
Pour l'onglet Annie : la dernière ligne d'Annie et la première de Michel
Pour l'onglet Michel : la dernière ligne de Michel et la ligne de Josée
Pour l'onglet Josée : La seule ligne de Josée

Voici notre code ;-)

Code:

Sub CreationOnglet()
Dim O As Integer
Dim Max As Integer
Dim Ws As Worksheet
Dim Debut As Integer, Fin As Integer
Dim Onglet As String


Application.ScreenUpdating = False
Set Ws = Sheets("Données")
Sheets("Données").Activate
Max = Range("A" & Rows.Count).End(xlUp).Row

For O = 2 To Max
    If Not ExisteFeuille(Ws.Range("A" & O).Text) Then
      Sheets.Add after:=Sheets(Sheets.Count)
      Onglet = Ws.Range("A" & O)
      ActiveSheet.Name = Onglet
      Sheets("Modèle").Cells.Copy Destination:=Range("A1")
      Range("A5") = Ws.Range("A" & O)
      Range("A2") = Ws.Range("B" & O)
      Range("A3") = Ws.Range("C" & O)
    
      Debut = O
      Fin = Nbre_Ligne_Nom(Onglet, Debut)

      Sheets("Données").Activate
      Range("D" & Debut & ":M" & Fin).Select
      Selection.Copy
      Sheets(Onglet).Activate
      Range("A7").Select
      ActiveSheet.Paste
      Range("A1").Select
   End If
Next O
Ws.Select
Application.ScreenUpdating = True
End Sub

'compte le nombre de lignes de données par prénom
Function Nbre_Ligne_Nom(Onglet As String, Compt As Integer) As Integer
Dim St As String
St = Sheets("Données").Range("A" & Compt).Value
    
While St = Onglet
    Compt = Compt + 1
    St = Sheets("Données").Range("A" & Compt).Value
Wend
Nbre_Ligne_Nom = Compt - 1
End Function

Function ExisteFeuille(Nom As String) As Boolean
' retourne True ou False qui indique la présence ou l'absence de la feuille
  On Error Resume Next
  ExisteFeuille = Sheets(Nom).Name <> ""
  On Error GoTo 0
End Function

Annie

klin89 · 11 Septembre 2013

Re : Macro pour boulcer dans une liste pour faire des tableaux/onglets

Bonsoir à tous,
Sous Excel 2003, du fonctionnel

VB:

Option Explicit
Sub Test()
'Dans VBA, menu Outils/références, cochez Microsoft Scripting Runtime.
Dim Dico As Dictionary, cel As Range, connue As Worksheet, Tablo, Tablo1()
Dim i As Long, k As Long, x As Long, NouvelleFeuille As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Dico = New Dictionary
'Suppression de toutes les feuilles sauf la 1ère
For i = Sheets.Count To 2 Step -1
  Sheets(i).Delete
Next i
'Boucle sur toutes les lignes remplies de la colonne A - A partir de A2
With Feuil1
  For Each cel In .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
    'Mise en mémoire des noms des onglets à créer
    If Not Dico.Exists(cel.Value) Then Dico.Add cel.Value, Array(cel, cel.Offset(0, 1), cel.Offset(0, 2))
  Next cel
  Tablo = .Range("A2:M" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
'Boucle sur toutes les noms en mémoire et création de la feuille
For i = 0 To Dico.Count - 1
  For k = LBound(Tablo, 1) To UBound(Tablo, 1)
    If Tablo(k, 1) = Dico.Keys(i) Then
      x = x + 1
      ReDim Preserve Tablo1(1 To 10, 1 To x)
      Tablo1(1, x) = Tablo(k, 4)
      Tablo1(2, x) = Tablo(k, 5)
      Tablo1(3, x) = Tablo(k, 6)
      Tablo1(4, x) = Tablo(k, 7)
      Tablo1(5, x) = Tablo(k, 8)
      Tablo1(6, x) = Tablo(k, 9)
      Tablo1(7, x) = Tablo(k, 10)
      Tablo1(8, x) = Tablo(k, 11)
      Tablo1(9, x) = Tablo(k, 12)
      Tablo1(10, x) = Tablo(k, 13)
    End If
  Next k
  NouvelleFeuille = Dico.Items(i)(0)
  On Error Resume Next
  Set connue = Sheets(NouvelleFeuille)
  If Err <> 0 Then Sheets.Add.Name = NouvelleFeuille
  On Error GoTo 0
  'Avec la feuille créée
  With Sheets(NouvelleFeuille)
    'On copie les intitulés
    .Cells(2, 1).Value = Dico.Items(i)(1)
    .Cells(3, 1).Value = Dico.Items(i)(2)
    .Cells(5, 1).Value = Dico.Items(i)(0)
    .Cells(6, 1).Resize(1, 10) = Array("N° Item", "N° Cas Type", "Date", _
     "Code Mesure", "Poids", "Résultat corrigé", "Résultat", "Minimum", _
     "Maximum", "Code unité")
     .Cells(6, 1).Resize(1, 10).Interior.ColorIndex = 43
     'On complète le tableau avec les données correspondantes à chacun
     .Cells(7, 1).Resize(UBound(Tablo1, 2), UBound(Tablo1, 1)) = Application.Transpose(Tablo1)
  End With
  Erase Tablo1: x = 0
'On passe à la feuille suivante
Next i
Sheets("Données").Move Sheets(1)
Sheets("Données").Select
Set Dico = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Je ne me suis pas attardé sur la mise en forme, mais tu peux compléter dans le bloc With Sheets(NouvelleFeuille)... End With

Klin89

Jack2 · 11 Septembre 2013

Re : Macro pour boulcer dans une liste pour faire des tableaux/onglets

Bonjour à tous,

Dans un post j'avais écrit que, étant débutant, je devrais me relire 7 fois… et bien regarder le résultat. Pour que la macro fonctionne correctement, il faire les deux modifications suivantes:

La fonction Nbre_Ligne_Nom ne comptait pas correctement le nombre de lignes et surtout renvoyait la position O incrémentée par l'intermédiaire de Compt :

Code:

Function Nbre_Ligne_Nom(Onglet As String, [B]ByVal [/B]Compt As Integer) As Integer
Dim St As String
Dim Init As Integer
St = Sheets("Données").Range("A" & Compt).Value
Init = Compt
While St = Onglet
    Compt = Compt + 1
    St = Sheets("Données").Range("A" & Compt).Value
Wend
Nbre_Ligne_Nom = Compt - Init
End Function

La valeur Fin ne prenait pas en compte la position de départ notée Debut, du fait que les données commencent à la deuxième ligne :

Code:

      Debut = O
      Fin = Debut + Nbre_Ligne_Nom(Onglet, Debut) - 1

      Sheets("Données").Activate
      Range("D" & Debut & ":M" & Fin).Select

Voilà, j'ai vérifié et ça a l'air de marcher correctement.
http://cjoint.com/?0IloP663hjc

Merci à klin89, je ne connaissais pas la notion de dictionnaire (à découvrir)

A+

truann01 · 11 Septembre 2013

Re : Macro pour boulcer dans une liste pour faire des tableaux/onglets

Jack2,

Encore une fois, merci pour ton aide. Pour quelqu'un qui débute, je trouve que tu te débrouilles très bien.

J'ai copié tes bouts de codes et au niveau de la définition de Nbre_Ligne_Nom, pourquoi faut-il ajouter :

ByVal Compt

Ça ne passe pas (erreur de compilation).

Peux-tu joindre le nouveau fichier SVP. Je n'arrive pas à ouvrir le lien. C'est bloqué par notre administrateur réseau.

Annie

truann01 · 11 Septembre 2013

Re : Macro pour boulcer dans une liste pour faire des tableaux/onglets

Bonjour à tous,

Merci klin89. Moi non plus je ne connaissais pas la notion "dictionary". Ton code fonctionne. Une petite question, est-il possible d'utiliser la feuille modèle comme gabarit pour concevoir les tableaux dans les onglets? Il se peut fort bien que je doive ajouter entre autre un logo et le fait de l'ajouter des choses dans le modèle est plus facile pour moi que de l'ajouter dans le code (je ne sais pas encore trop comment m'y prendre pour programmer).

Annie

Jack2 · 11 Septembre 2013

Re : Macro pour boulcer dans une liste pour faire des tableaux/onglets

Bonjour à tous,

Merci pour ta première phrase, mais pour le moment je continue à apprendre et à "bidouiller", il reste beaucoup de chemin. Le mot clé ByVal indique que la variable est passée par valeur et retourne inchangée. Dans le cas présent pour Stéphane Compt = 2 au début et à la fin de la fonction, ce qui permet de calculer la variable Fin (Sub CreationOnglet) avec la valeur de Debut inchangée.

Je n'ai pas d'erreur de compilation. Est-ce que tu peux me dire à quelle ligne tu as cette erreur (en faisant F8 : suivi pas à pas).

(je viens de découvrir comment on joint une pièce à partir du site. Avant j'utilisais le service cjoint.com)

A+

truann01 · 11 Septembre 2013

Re : Macro pour boulcer dans une liste pour faire des tableaux/onglets

Bonjour à toi Jack2, à tous,

Yeeeessss! J'ai récupéré ton fichier et tout, abosulment tout fonctionne! Un très très gros MERCI à toi et aussi à tous les autres qui m'ont aidé d'une quelconque façon. Je me rends compte que j'ai vraiment beaucoup de croutes à manger avant de pouvoir être à l'aise en vba (surtout les boulces! ;-) ), mais je ne désespère pas d'y arriver! En analysant les bouts de code qui m'ont été envoyé, ça m'aide à démystifier la programmation vba.

Ce qui ne fonctionnait pas tantôt lorsque j'ai copié le code faisant référence à ByVal, c'était qu'il y avait des B entre crochets... C'était un peu étrange comme code « B ByVal /B » mais comme je ne suis pas ferrée je l'ai copié quand même. Ben oui, j'ai fait ça! !!! J'imagine qu'en collant ton code dans la balise, le ByVal devait être en caractère gras, il a donc été transformé en B ByVal /B. ???

Encore une fois merci,

Au plaisir de se recroiser sur le site,

Annie

klin89 · 11 Septembre 2013

Re : Macro pour boulcer dans une liste pour faire des tableaux/onglets

Bonsoir à tous,

A tester dans le fichier du post #4, attention au CodeName de la feuille concernée : ici Feuil6

VB:

Option Explicit
Sub Test()
'Dans VBA, menu Outils/références, cochez Microsoft Scripting Runtime.
Dim Dico As Dictionary, cel As Range, Tablo, Tablo1()
Dim i As Long, j As Long, k As Long, x As Long, NouvelleFeuille As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Dico = New Dictionary
'Suppression de toutes les feuilles sauf la 1ère et la 2ème
For i = Sheets.Count To 3 Step -1
  Sheets(i).Delete
Next i
'Boucle sur toutes les lignes remplies de la colonne A - A partir de A2
With Feuil6
  For Each cel In .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
    'Mise en mémoire des noms des onglets à créer
   If Not Dico.Exists(cel.Value) Then Dico.Add cel.Value, Array(cel, cel.Offset(0, 1), cel.Offset(0, 2))
  Next cel
  Tablo = .Range("A2:M" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
'Boucle sur toutes les noms en mémoire et création de la feuille
For i = 0 To Dico.Count - 1
  For k = LBound(Tablo, 1) To UBound(Tablo, 1)
    If Tablo(k, 1) = Dico.Keys(i) Then
      x = x + 1
      ReDim Preserve Tablo1(1 To 10, 1 To x)
      For j = 1 To 10
        Tablo1(j, x) = Tablo(k, j + 3)
      Next j
    End If
  Next k
  On Error Resume Next
  NouvelleFeuille = Dico.Items(i)(0)
  If Err = 0 Then
  Sheets("Modèle").Copy after:=Sheets(Sheets.Count)
  Sheets(Sheets.Count).Name = NouvelleFeuille
  End If
  On Error GoTo 0
  'Avec la feuille créée
 With Sheets(NouvelleFeuille)
    'On copie les intitulés
    .Cells(2, 1).Value = Dico.Items(i)(1)
    .Cells(3, 1).Value = Dico.Items(i)(2)
    .Cells(5, 1).Value = Dico.Items(i)(0)
     'On complète le tableau avec les données correspondantes à chacun
    .Cells(7, 1).Resize(UBound(Tablo1, 2), UBound(Tablo1, 1)) = Application.Transpose(Tablo1)
  End With
  Erase Tablo1: x = 0
'On passe à la feuille suivante
Next i
Sheets("Données").Move Sheets(1)
Sheets("Données").Select
Set Dico = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Klin89

klin89 · 12 Octobre 2013

Re : Macro pour boulcer dans une liste pour faire des tableaux/onglets

Bonsoir le forum,

De retour sur ce fil,
On peut se passer de supprimer les feuilles existantes.

VB:

Sub Test()
'Dans VBA, menu Outils/références, cochez Microsoft Scripting Runtime.
Dim Mondico As Dictionary, Tablo()
Dim DLig As Long, DLig1 As Long, DCol As Byte, i As Long
Dim NomOnglet As String
Application.ScreenUpdating = False
Set Mondico = New Dictionary
With Feuil1
  DLig = .Range("A" & Rows.Count).End(xlUp).Row
  DCol = .Cells(1, Columns.Count).End(xlToLeft).Column
  For Each cel In .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
    'Mise en mémoire des noms des onglets à créer
    If Not Mondico.Exists(cel.Value) Then Mondico.Add cel.Value, Array(cel, cel.Offset(0, 1), cel.Offset(0, 2))
  Next cel
  Tablo = Mondico.Keys
  For i = 0 To Mondico.Count - 1
    NomOnglet = Tablo(i)
    If FeuilleExiste(NomOnglet) = False Then
      Sheets.Add after:=Sheets(Sheets.Count)
      With ActiveSheet
        .Name = NomOnglet
        .Cells(2, 1).Value = Mondico.Items(i)(1)
        .Cells(3, 1).Value = Mondico.Items(i)(2)
        .Cells(5, 1).Value = Mondico.Items(i)(0)
        .Cells(6, 1).Resize(1, 10) = Array("N° Item", "N° Cas Type", "Date", _
        "Code Mesure", "Poids", "Résultat corrigé", "Résultat", "Minimum", _
        "Maximum", "Code unité")
        .Cells(6, 1).Resize(1, 10).Interior.ColorIndex = 43
      End With
    ElseIf Not IsEmpty(Sheets(NomOnglet).Range("A7")) Then
      DLig1 = Sheets(NomOnglet).Range("A" & Rows.Count).End(xlUp).Row
      Sheets(NomOnglet).Range("A7:J" & DLig1).ClearContents
    Else
      '''
    End If
  Next i
  Set Mondico = Nothing
  For i = 2 To DLig
    NomOnglet = .Cells(i, 1)
    .Range(.Cells(i, 4), .Cells(i, DCol)).Copy Destination:=Sheets(NomOnglet).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
  Next i
End With
Application.ScreenUpdating = True
End Sub

VB:

Function FeuilleExiste(nom As String) As Boolean
On Error Resume Next
  FeuilleExiste = Sheets(nom).Name <> ""
  On Error GoTo 0
End Function

Klin89

Macro pour boulcer dans une liste pour faire des tableaux/onglets

XLDnaute Nouveau

Pièces jointes

XLDnaute Accro

XLDnaute Occasionnel

XLDnaute Nouveau

Pièces jointes

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Nouveau

XLDnaute Accro

Pièces jointes

XLDnaute Occasionnel

XLDnaute Nouveau

XLDnaute Nouveau

XLDnaute Occasionnel

Pièces jointes

XLDnaute Nouveau

XLDnaute Accro

XLDnaute Accro

Pièces jointes

Discussions similaires

Partager cette page

Statistiques des forums