Transfert données pour chaque onglets - aide

T

thespeedy20

XLDnaute Occasionnel
Bonjour le forum,

En colonne A, j'ai des noms et je crée des onglets portant le nom...pas de soucis à ce niveau là...
Je dois transférer les données de la col B à N de chaque nom de la colonne A dans son onglet dédié...

Puis-je avoir votre aide
Merci d'avance

Oli
 

Pièces jointes

  • Onglets.xlsm
    19.2 KB · Affichages: 21
Trier par date Trier par votes
B

Bebere

XLDnaute Barbatruc
bonjour
un exemple
VB: 
Sub Distribue() 'seulement si feuille données est seule
    Dim a(), b(), i As Long, j As Long, k As Long, ligne As Long, indice As Long
    Dim item, dico, MonDico, Fe As Worksheet
    
    Application.ScreenUpdating = False
    
    With Worksheets("Données")
        a = .Range("A2:N" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
    End With

    Set dico = CreateObject("scripting.dictionary")

    For i = 1 To UBound(a)
        dico(a(i, 1)) = a(i, 1)
    Next

    For Each item In dico.items
        Set MonDico = CreateObject("scripting.dictionary")
        Erase b: k = 0
        For i = 1 To UBound(a)
            If a(i, 1) = item Then
                CléBase = item
                Clé = CléBase
                indice = 1
                Do While MonDico.exists(Clé)
                    Clé = CléBase & indice
                    indice = indice + 1
                Loop
                MonDico(Clé) = i
            End If
        Next i
        CléBase = item
        Clé = CléBase
        indice = 1
        Do While MonDico.exists(Clé)
            ligne = MonDico(Clé)
            k = k + 1
            ReDim Preserve b(1 To 14, 1 To k)
            For j = 1 To UBound(a, 2)
                b(j, k) = a(ligne, j)
            Next
            Clé = CléBase & indice
            indice = indice + 1
        Loop
        If k > 1 Then
            b = Application.Transpose(b)
            Set Fe = Worksheets.Add(after:=Sheets(Sheets.Count))
            Fe.Name = b(1, 1)
            Worksheets("Données").Range("A1:N1").Copy Destination:=Fe.Range("A1")
            Fe.Range("A2").Resize(UBound(b, 1), UBound(b, 2)) = b
        Else
            Set Fe = Worksheets.Add(after:=Sheets(Sheets.Count))
            Fe.Name = b(1, 1)

            Worksheets("Données").Range("A1:N1").Copy Destination:=Fe.Range("A1")
            For i = 1 To UBound(b)
                Fe.Cells(2, i) = b(i, 1)
            Next i
        End If
    Next item
    Application.ScreenUpdating = True

End Sub
 
Vote positif 0 Vote négatif
Hasco

Hasco

XLDnaute Barbatruc
Repose en paix
Bonjour,

Dans le fichier joint la macro suivante :
VB: 
Sub CreerFeuillesProfs()
    Dim Dico As Object
    Dim Profs() As Variant, Prof As Variant
    Dim Fe As Worksheet, FeTmp As Worksheet
    Dim Plage As Range
    Dim Cel As Range

    'défini la plage des numéros en colonne A (à partir de A1) de la feuille "Feuil1", à adapter...
    Set Plage = Worksheets("Données").Range("A1").CurrentRegion
    '
    ' Chargement de tous les noms dans un tableau en mémoire
    Profs = Plage.Offset(1).Resize(Plage.Rows.Count - 1).Columns(1).Value
    '
    ' Création d'un dictionnaire pour ne conserver que des noms uniques
    Set Dico = CreateObject("scripting.dictionary")
    '
    ' Création de la liste unique de noms
    For Each Prof In Profs: Dico(Prof) = Prof: Next Prof
    '
    ' Récupération de la liste de noms uniques dans le tableau
    Profs = Dico.keys
    Set Dico = Nothing    ' inutile de garder le dico
    '
    ' Figer l'application
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    '
    ' Création d'une feuille temporaire pour y inscrire les critère de filtre
    Set FeTmp = getSheet("Critères")
    FeTmp.Range("A1") = "PROFESSEUR"
    '
    ' Boucler sur chaque prof du tableau
    For Each Prof In Profs
        Set Fe = getSheet(Prof)
        If Not Fe Is Nothing Then
            FeTmp.Range("A2") = Prof
            Plage.AdvancedFilter xlFilterCopy, FeTmp.Range("A1:A2"), Fe.Range("A1")
        End If
    Next
    With Application
        '
        ' destruction de la feuille fetmp
        .DisplayAlerts = False
        FeTmp.Delete
        .DisplayAlerts = True
        '
        '  Défiiger l'application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
End Sub


Et la fonction perso getSheet
Code: 
Function getSheet(ByVal SheetName As String, Optional CreateIfNotExists As Boolean = True) As Worksheet
    If Trim(SheetName) = "" Then Exit Function
    On Error Resume Next
    With ThisWorkbook
        Set getSheet = .Sheets(SheetName)
        If getSheet Is Nothing And CreateIfNotExists Then
            Set getSheet = ThisWorkbook.Sheets.Add(After:=.Sheets(.Sheets.Count))
            getSheet.Name = SheetName
        End If
    End With
    On Error GoTo 0
End Function

cordialement
 

Pièces jointes

  • Onglets.xlsm
    27.5 KB · Affichages: 12
Vote positif 0 Vote négatif
T

thespeedy20

XLDnaute Occasionnel
Bonjour Bebere, Roblochon
Bonjour le forum,

@Bebere :
merci pour ta proposition, elle fonctionne, mais dans le cadre d'une mise à jour, il me dit que 'l'onglet existe déjà... et cela s'arrête.

@Roblochon :
ton fichier fonctionne très bien. Si je décide d'ajouter des lignes dans ma base de données est il possible de faire une mise à jour des onglets ? et autre petite demande, est il possible de passer une ligne entre chaque nouveau degré dans le même onglet ?

je vous remercie déjà pour le temps consacré à mon projet

OLi
 
Vote positif 0 Vote négatif
T

thespeedy20

XLDnaute Occasionnel
re,

Avec cette ajout de macro, j'arrive à passer une ligne entre chaque nouveau degré ou cours...

VB: 
Sub Macro1()
Dim WS As Object
For Each WS In ThisWorkbook.Worksheets
 WS.Select
 DernLig = Columns(1).Rows(ActiveSheet.Rows.Count).End(xlUp).Row
 For Lig = DernLig To 3 Step -1
  If Cells(Lig, 2) <> Cells(Lig - 1, 2) Or Cells(Lig, 3) <> Cells(Lig - 1, 3) Then
     Rows(Lig).Insert
 End If
 Next
Next
End Sub

Il ne me reste plus qu'un petit code pour en cas de mise à jour à jour de la base...

une petite âme charitable pour m'aider....

Merci

Oli
 
Vote positif 0 Vote négatif
Jacky67

Jacky67

XLDnaute Barbatruc
thespeedy20 à dit:
Jacky67,
Ton poste à disparu ? pourquoi ?
Cliquez pour agrandir...
Oupps!!!
Le revoila :)
VB: 
Sub Testjj()
    Dim Plage As Range, C, Lig
    Dim Dico
    Set Dico = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
    With Worksheets("Données")
        If .FilterMode Then .ShowAllData
        Set Plage = Worksheets("Données").Range("A1").CurrentRegion
        If Application.CountA(Plage.Columns(1)) < 3 Then MsgBox "Données manquantes(Min=2)", vbInformation, "Information": Exit Sub
        Set Dico = CreateObject("scripting.dictionary")
        For Each C In Plage.Offset(1).Resize(Plage.Rows.Count - 1).Columns(1).Value: Dico(C) = C: Next
        For Each C In Dico.keys
            On Error Resume Next    'dans le cas ou la feuille n'existe pas !
            Application.DisplayAlerts = False
            Sheets(C).Delete
            Application.DisplayAlerts = True
            On Error GoTo 0
            Worksheets.Add after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = C
            Plage.AutoFilter Field:=1, Criteria1:=C
            Plage.Offset(, 1).Resize(, Plage.Columns.Count - 1).SpecialCells(xlCellTypeVisible).Copy ActiveSheet.[a1]
            With ActiveSheet
                   For Lig = .Cells(.Rows.Count, "A").End(xlUp).Row To 3 Step -1
                     If .Cells(Lig, 1) <> .Cells(Lig - 1, 1) And .Cells(Lig, 2) <> .Cells(Lig - 1, 2) Then
                        .Rows(Lig).Insert
                    End If
                Next
            End With
        Next
        Plage.AutoFilter
        .Activate
    End With
End Sub
 

Pièces jointes

  • test2 Onglets.xlsm
    35.5 KB · Affichages: 5
Vote positif 0 Vote négatif
T

thespeedy20

XLDnaute Occasionnel
Bonjour Jacky67,
Bonjour le Forum,

Après un petit test, au niveau de l'exportation, cela fonctionne... il y a juste une petite chose au niveau du tri...

le tri doit être par cours, par degré, par jour et élèves...
je te montre cela dans le fichier

Merci d'avance

Oli
 

Pièces jointes

  • test2 Onglets_tri.xlsm
    23.4 KB · Affichages: 12
Vote positif 0 Vote négatif
Jacky67

Jacky67

XLDnaute Barbatruc
thespeedy20 à dit:
Bonjour Jacky67,
Bonjour le Forum,

Après un petit test, au niveau de l'exportation, cela fonctionne... il y a juste une petite chose au niveau du tri...

le tri doit être par cours, par degré, par jour et élèves...
je te montre cela dans le fichier

Merci d'avance

Oli
Cliquez pour agrandir...
RE,
....juste une petite chose au niveau du tri...
Pour la petite chose
Faire un tri [A-Z] sur "Jour", "Degré", "Cours" avant de lancer la macro,
je pense sera le meilleur résultat que l'on puisse obtenir pour le prof. "toto"
 
Dernière édition:
Vote positif 0 Vote négatif
T

thespeedy20

XLDnaute Occasionnel
Bonjour Jacky67,

Merci pour l 'info,

voici ce que j'ai trouvé:

VB: 
Sub tri()

Dim nbLignes As Integer
Worksheets("Feuil1").Range("A2").Select
nbLignes = Range("A2", Selection.End(xlDown)).Cells.Count

With Sheets("feuil1").Range("A2:E" & nbLignes)
.Sort Key1:=Sheets("feuil1").Range("E2"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With

With Sheets("feuil1").Range("A2:E" & nbLignes)
.Sort Key1:=Sheets("feuil1").Range("D2"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With

With Sheets("feuil1").Range("A2:E" & nbLignes)
.Sort Key1:=Sheets("feuil1").Range("C2"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With

With Sheets("feuil1").Range("A2:E" & nbLignes)
.Sort Key1:=Sheets("feuil1").Range("B2"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With

With Sheets("feuil1").Range("A2:E" & nbLignes)
.Sort Key1:=Sheets("feuil1").Range("A2"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With

With Sheets("feuil1").Range("A2:E" & nbLignes)
.Sort Key1:=Sheets("feuil1").Range("D2"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With

End Sub

Oli
 
Vote positif 0 Vote négatif
Jacky67

Jacky67

XLDnaute Barbatruc
thespeedy20 à dit:
Bonjour Jacky67,

Merci pour l 'info,

voici ce que j'ai trouvé:

VB: 
Sub tri()

Dim nbLignes As Integer
Worksheets("Feuil1").Range("A2").Select
nbLignes = Range("A2", Selection.End(xlDown)).Cells.Count

With Sheets("feuil1").Range("A2:E" & nbLignes)
.Sort Key1:=Sheets("feuil1").Range("E2"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With

With Sheets("feuil1").Range("A2:E" & nbLignes)
.Sort Key1:=Sheets("feuil1").Range("D2"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With

With Sheets("feuil1").Range("A2:E" & nbLignes)
.Sort Key1:=Sheets("feuil1").Range("C2"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With

With Sheets("feuil1").Range("A2:E" & nbLignes)
.Sort Key1:=Sheets("feuil1").Range("B2"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With

With Sheets("feuil1").Range("A2:E" & nbLignes)
.Sort Key1:=Sheets("feuil1").Range("A2"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With

With Sheets("feuil1").Range("A2:E" & nbLignes)
.Sort Key1:=Sheets("feuil1").Range("D2"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With

End Sub

Oli
Cliquez pour agrandir...
Re...
Et dans la macro du classeur du prof. de toto cela pourrait ressembler à ceci
VB: 
Sub Testjj()
    Dim Plage As Range, C, Lig&
    Dim Dico
    Set Dico = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
    With Worksheets("Données")
        If .FilterMode Then .ShowAllData
        Set Plage = Worksheets("Données").Range("A1").CurrentRegion
        If Application.CountA(Plage.Columns(1)) < 3 Then MsgBox "Données manquantes(Min=2)", vbInformation, "Information": Exit Sub
        Plage.Sort key1:=.[d2], Order1:=xlAscending, Header:=xlYes
        Plage.Sort key1:=.[c2], Order1:=xlAscending, Header:=xlYes
        Plage.Sort key1:=.[b2], Order1:=xlAscending, Header:=xlYes
        '-------------
        '-------------
        Suite de la macro

Bon courage
 
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

B
  • Question
Microsoft 365 compiler onglets excel avec VBA
Réponses
6
Affichages
263
Boubie
B
D
  • Question
Microsoft 365 Infos dans plusieurs onglets à réorganiser dans plusieurs onglets
Réponses
7
Affichages
308
fanfan38
fanfan38
M
  • Résolu(e)
Microsoft 365 Code pour transfert
2
Réponses
15
Affichages
341
Marvin57
M
R
  • Question
Microsoft 365 Recuperation de données entre les onglets
Réponses
3
Affichages
339
djidji59430
djidji59430
WTF
  • Résolu(e)
Microsoft 365 Créer une base de données à partir de 2 onglets
Réponses
3
Affichages
207
WTF
WTF
G
  • Question
Microsoft 365 Macro VBA - Excel
Réponses
12
Affichages
230
Dranreb
Dranreb
M
  • Question
Power Query Nom des onglets des fichiers importés dans Power query
Réponses
13
Affichages
564
Mongo
M
J
  • Question
Microsoft 365 extraction VBA avec formule si
Réponses
10
Affichages
330
Phil69970
Phil69970
B
  • Question
XL 2016 Formule Recherche d'une cellule dans plusieurs onglets différents
Réponses
2
Affichages
187
oguruma
oguruma
O
  • Résolu(e)
XL 2016 Transfert de données sous conditions
Réponses
4
Affichages
162
sylvanu
sylvanu

Membres actuellement en ligne

10 membres et 102 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 115
Messages
2 085 456
Membres
102 891
dernier inscrit
cocowild