Autres Créer un Tableau automatiquement à partir d'un autre Partie I.

Pickis

XLDnaute Nouveau
Bonjour, je voulais savoir si il était possible de créer un Tableau automatiquement a partir d'un tableau qui lui servirai de référence.
En gros dans mon tableau de base j'ai 2 colonne. 1 pour le nombre d'élèves. 2 pour le nom de la classe :
Tableau Référent.
Visu1.png

Je voudrais que ça me génére un tableau comme ça :
Tableau Automatique
Visu2.png
etc..
Le Tableau Automatique va générer 28 ligne de 6°7, 29 de 6°6 et 27 de 6°5. Et dans la colonne N°, le nombre total d'élèves.
Mon fichier d'exemple en pièce jointe et fait sous Numbers (Mac) mais je peux aussi travailler sous PC.
Ca vous permet d'avoir un visuel mais il y a aucune formule c'est juste pour vous donner une idée.
Cordialement
Pickis
 

Pièces jointes

  • Tableau Ecole test.xlsx
    8.5 KB · Affichages: 12
Solution
Bonjour Pickis, chris, le forum,

Fichier (2), ici j'ai quand même ajouté Application.ScreenUpdating = False :
VB:
Private Sub Worksheet_Activate()
Dim deb As Range, h&, c As Range
Set deb = [A2] '1ère cellule à remplir, à adapter éventuellement
With Sheets("Feuille 1").[A:A] 'nom de la feuille à adapter
    h = Application.SumIf(.Cells, ">=1", .Cells) 'SOMME.SI
    If h Then
        Application.ScreenUpdating = False 'fige l'écran
        deb = 1: deb.Resize(h).DataSeries 'numérotation
        deb.Resize(h, 3).Borders.Weight = xlThin 'bordures
        For Each c In .SpecialCells(xlCellTypeConstants, 1)
            If c >= 1 Then deb(1, 2).Resize(c) = c(1, 2): _
                deb(1, 3).Resize(c) = "=TEXT(RC[-2],""0000.\j\p\g"")": Set...

Robert

XLDnaute Barbatruc
Repose en paix
Bonjour Pickis, bonjour le forum,

Peut-être comme ça :

VB:
Sub Macro1()
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim NE As Integer 'déclare la variable NE (Nombre d'Élèves)
Dim CL As String 'déclare la variable CL (Classe)
Dim LI As Integer 'déclare la variable LI (LIgne)

Set OS = Worksheets("Feuille 1") 'définit l'onglet source OS
Set OD = Worksheets("Tableau Automatique") 'définit l'onglet destination OD
OD.Range("A1").CurrentRegion.ClearContents 'efface les anciennes valeurs de l'onglet destination
OD.Range("A1").Value = "N°" 'écrit en A1
OD.Range("B1").Value = "Classe" 'écrit en B1
TV = OS.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
For I = 2 To UBound(TV, 1) - 1 'boucle sur toutes les ligne I du tableau des valeurs (de la seconde à l'avant dernière)
    NE = TV(I, 1) 'définit le nombre d'élève NE
    CL = TV(I, 2) 'définit la classe CL
    LI = OD.Cells(Application.Rows.Count, "B").End(xlUp).Row + 1 'définit la première ligne vide LI de la colonne B de l'onglet OD
    'renvoie la classe CL dans la cellule ligne LI colonne B redimensionnée à NE lignes et 1 colonne
    OD.Cells(LI, "B").Resize(NE, 1).Value = CL
Next I 'prochaine valeur de la boucle
LI = OD.Cells(Application.Rows.Count, "B").End(xlUp).Row - 1 'redéfinit la ligne LI
With OD.Cells(2, "A") 'prend en compte la cellule A2
    .Value = 1 'écrit 1 en A2
    .DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
        Step:=1, Stop:=LI, Trend:=False ' créé une serie en colonne de type linéaire par pas de 1 de 1 à LI
End With
End Sub
 

Staple1600

XLDnaute Barbatruc
Bonjour le fil,

Un autre possibilité (avec Tableau => Array, mais pas tout à fait comme Robert)
VB:
Sub RecopieTableaux()
Dim a, c, i&, j&, k&
a = Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row)
k = Application.Sum(Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row))
ReDim c(1 To k, 1 To 2)
For i = LBound(a, 1) To UBound(a, 1)
  If a(i, 1) <> "" Or a(i, 1) <> 0 Then
    For k = 1 To a(i, 1)
      j = j + 1
      c(j, 1) = k: c(j, 2) = a(i, 2)
    Next k
  End If
Next i
'ici pour changer la localisation du nouveau tableau
Columns("D:E").ClearContents
[D1:E1] = Array("N°", "Classe")
[D2].Resize(UBound(c, 1), UBound(c, 2)) = c
Columns("D:E").AutoFit
End Sub
NB: Ici, le tableau est récréé en colonnes DE
Donc adapter dans le code selon besoin.
 

job75

XLDnaute Barbatruc
Bonsoir Pickis, fanfan38, Robert, JM,

Puisque le nombre de classes n'est jamais très élevé (quelques dizaines) il n'est pas nécessaire d'utiliser des tableaux VBA.

Même Application.ScreenUpdating = False est inutile, voyez cette macro dans le code de la dernière feuille du fichier joint :
VB:
Private Sub Worksheet_Activate()
Dim deb As Range, h&, c As Range
Set deb = [A2] '1ère cellule à remplir, à adapter éventuellement
With Sheets("Feuille 1").[A:A] 'nom de la feuille à adapter
    h = Application.SumIf(.Cells, ">0", .Cells) 'SOMME.SI
    If h Then
        deb = 1: deb.Resize(h).DataSeries 'numérotation
        deb.Resize(h, 2).Borders.Weight = xlThin 'bordures
        With .SpecialCells(xlCellTypeConstants, 1)
            For Each c In .Cells
                If c > 0 Then deb(1, 2).Resize(c) = c(1, 2): Set deb = deb.Offset(c)
            Next
        End With
    End If
End With
deb.Resize(Rows.Count - deb.Row + 1, 2).Delete xlUp 'RAZ en dessous
End Sub
Elle se déclenche automatiquement quand on active la feuille.

Nota : la ligne du Total en Feuille 1 n'a aucune importance.

A+
 

Pièces jointes

  • Tableau Ecole test(1).xlsm
    20.7 KB · Affichages: 11

Pickis

XLDnaute Nouveau
Bonsoir Pickis, fanfan38, Robert, JM,

Puisque le nombre de classes n'est jamais très élevé (quelques dizaines) il n'est pas nécessaire d'utiliser des tableaux VBA.

Même Application.ScreenUpdating = False est inutile, voyez cette macro dans le code de la dernière feuille du fichier joint :
VB:
Private Sub Worksheet_Activate()
Dim deb As Range, h&, c As Range
Set deb = [A2] '1ère cellule à remplir, à adapter éventuellement
With Sheets("Feuille 1").[A:A] 'nom de la feuille à adapter
    h = Application.SumIf(.Cells, ">0", .Cells) 'SOMME.SI
    If h Then
        deb = 1: deb.Resize(h).DataSeries 'numérotation
        deb.Resize(h, 2).Borders.Weight = xlThin 'bordures
        With .SpecialCells(xlCellTypeConstants, 1)
            For Each c In .Cells
                If c > 0 Then deb(1, 2).Resize(c) = c(1, 2): Set deb = deb.Offset(c)
            Next
        End With
    End If
End With
deb.Resize(Rows.Count - deb.Row + 1, 2).Delete xlUp 'RAZ en dessous
End Sub
Elle se déclenche automatiquement quand on active la feuille.

Nota : la ligne du Total en Feuille 1 n'a aucune importance.

A+

Super et merci pour la réponse, avec mon tout petit niveau j ai reussi a rajouter 2 p'tit trucs a ton code en ligne 13,14,15
VB:
Private Sub Worksheet_Activate()
Dim deb As Range, h&, c As Range
Set deb = [A2] '1ère cellule à remplir, à adapter éventuellement
With Sheets("Feuille 1").[A:A] 'nom de la feuille à adapter
    h = Application.SumIf(.Cells, ">0", .Cells) 'SOMME.SI
    If h Then
        deb = 1: deb.Resize(h).DataSeries        'numérotation
        deb.Resize(h, 2).Borders.Weight = xlThin 'bordures
        With .SpecialCells(xlCellTypeConstants, 1)
            For Each c In .Cells
                If c > 0 Then deb(1, 2).Resize(c) = c(1, 2): Set deb = deb.Offset(c)
                Range("C1").Select
    ActiveCell.FormulaR1C1 = "Indiv"
    Range("C2").Select
    ActiveCell.FormulaR1C1 = "=RC[-2]&"".jpg"""
            Next
        End With
    End If
End With
deb.Resize(Rows.Count - deb.Row + 1, 2).Delete xlUp    'RAZ en dessous
End Sub

Mes soucis :
1/ je voudrais que la formule de ma colonne "Indiv" s'ajuste automatiquement a mon tableau.

2/ Colonne A il me faut une numérotation avec au moins 3 ou 4 zéros devant mon chiffre Ex-0001 (J'ai trouvé comment faire dans excel),
par contre dans ma nouvelle Colonne Indiv Il veut pas me prendre cette numérotation avec 3 ou 4 zéros devant mon chiffre, pourtant cette dernière se structure avec les valeurs de la colonne A.
J'espère avoir été clair
Cordialement
 
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour Pickis, chris, le forum,

Fichier (2), ici j'ai quand même ajouté Application.ScreenUpdating = False :
VB:
Private Sub Worksheet_Activate()
Dim deb As Range, h&, c As Range
Set deb = [A2] '1ère cellule à remplir, à adapter éventuellement
With Sheets("Feuille 1").[A:A] 'nom de la feuille à adapter
    h = Application.SumIf(.Cells, ">=1", .Cells) 'SOMME.SI
    If h Then
        Application.ScreenUpdating = False 'fige l'écran
        deb = 1: deb.Resize(h).DataSeries 'numérotation
        deb.Resize(h, 3).Borders.Weight = xlThin 'bordures
        For Each c In .SpecialCells(xlCellTypeConstants, 1)
            If c >= 1 Then deb(1, 2).Resize(c) = c(1, 2): _
                deb(1, 3).Resize(c) = "=TEXT(RC[-2],""0000.\j\p\g"")": Set deb = deb.Offset(c)
        Next
    End If
End With
deb.Resize(Rows.Count - deb.Row + 1, 3).Delete xlUp 'RAZ en dessous
End Sub
Edit 1 : >=1 va mieux que > 0.

Edit 2 : chris sur ton fichier la numérotation en colonne E n'est pas ce qui est demandé.

Bonne journée.
 

Pièces jointes

  • Tableau Ecole test(2).xlsm
    21.3 KB · Affichages: 17
Dernière édition:

chris

XLDnaute Barbatruc
RE
Edit 2 : chris sur ton fichier la numérotation en colonne E n'est pas ce qui est demandé.
[/QUOTE]
Effectivement :eek:
Facile à modifier.
En revanche la formule ajoutée dans une 3ème colonne, bien que possible, ne serait pas calculée automatiquement... par contre on peut mettre le résultat et non la formule...
 
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 924
Membres
101 841
dernier inscrit
ferid87