XL 2013 Copier coller VBA

S

SAMESS

XLDnaute Nouveau
Bonjour Forum,

Je recherche un code vba qui me permette d'extraire le planning de chaque prof dans une nouvelle feuille avec son nom (voir exemple)
Merci d'avance
 

Pièces jointes

  • exemple.xlsx
    11.8 KB · Affichages: 13
Solution
job75
Bonjour Marcel32 et merci d'être intervenu.

Maintenant les choses sont plus claires, pour les doublons il y a la date mais aussi la fonction occupée.

Voyez ce fichier (3) et le complément de code :
VB: 
'---vérification des doublons---
Set d = CreateObject("Scripting.Dictionary")
Set P = F.[B2].CurrentRegion 'à adapter
For i = 2 To P.Rows.Count
    For j = 4 To 6
        x = LCase(P(i, j) & P(i, 7) & P(1, j))
        If d.exists(x) Then MsgBox "Doublon sur '" & P(i, j) & "' pour le N° " & d(x) & " et le N° " & P(i, 1) & " !", 48: Exit Sub
        d(x) = P(i, 1) 'mémorise le N°
Next j, i
Aucune feuille ne sera créée tant qu'il restera un doublon.

A+
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Bonjour SAMESS, Marcel32, Bruno,

Au départ seule la feuille "Planning" est nécessaire.

Voyez le fichier joint et la macro du bouton :
VB: 
Sub Creation_Feuilles()
Dim F As Worksheet, i&, d As Object, P As Range, ncol%, j%, x$, k%, lig&
Set F = Sheets("Planning")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'---suppression des feuilles---
F.Move Before:=Sheets(1)
For i = Sheets.Count To 2 Step -1
    Sheets(i).Delete
Next i
'---création et remplissage des feuilles---
Set d = CreateObject("Scripting.Dictionary")
Set P = F.[B2].CurrentRegion 'à adapter
ncol = P.Columns.Count
For i = 2 To P.Rows.Count
    For j = 4 To 6 'colonnes à adapter
        x = Application.Proper(Trim(P(i, j))) 'NOMPROPRE
        If x <> "" Then
            If Not d.exists(x) Then
                Sheets.Add After:=Sheets(1)
                Sheets(2).Name = x
                For k = Sheets.Count To 3 Step -1
                    If x > Sheets(k).Name Then Sheets(x).Move After:=Sheets(k): Exit For 'classement des feuilles
                Next k
                With Sheets(x)
                    For k = 1 To ncol
                        .Columns(k).ColumnWidth = P(1, k).ColumnWidth 'largeurs des colonnes
                    Next
                    P.Rows(1).Copy .Cells(1)
                End With
            End If
            d(x) = d(x) + 1
            lig = d(x) + 1
            With Sheets(x).Cells(lig, 1)
                P.Rows(i).Copy .Cells
                .Value = P(i, 1) 'remplace la formule par la valeur
                With .Resize(, ncol).Interior
                    If lig Mod 2 Then .ColorIndex = xlNone Else .Color = RGB(221, 235, 247) 'bleu clair
                End With
            End With
        End If
Next j, i
F.Activate
End Sub
A+
 

Pièces jointes

  • Planning(1).xlsm
    29.9 KB · Affichages: 13
Dernière édition:
Vote positif 0 Vote négatif
S

SAMESS

XLDnaute Nouveau
job75 à dit:
Bonjour SAMESS, Marcel32, Bruno,

Au départ seule la feuille "Planning" est nécessaire.

Voyez le fichier joint et la macro du bouton :
VB: 
Sub Creation_Feuilles()
Dim F As Worksheet, i&, d As Object, P As Range, ncol%, j%, x$, k%, lig&
Set F = Sheets("Planning")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'---suppression des feuilles---
F.Move Before:=Sheets(1)
For i = Sheets.Count To 2 Step -1
    Sheets(i).Delete
Next i
'---création et remplissage des feuilles---
Set d = CreateObject("Scripting.Dictionary")
Set P = F.[B2].CurrentRegion 'à adapter
ncol = P.Columns.Count
For i = 2 To P.Rows.Count
    For j = 4 To 6 'colonnes à adapter
        x = Application.Proper(Trim(P(i, j))) 'NOMPROPRE
        If x <> "" Then
            If Not d.exists(x) Then
                Sheets.Add After:=Sheets(1)
                Sheets(2).Name = x
                For k = Sheets.Count To 3 Step -1
                    If x > Sheets(k).Name Then Sheets(x).Move After:=Sheets(k): Exit For 'classement des feuilles
                Next k
                With Sheets(x)
                    For k = 1 To ncol
                        .Columns(k).ColumnWidth = P(1, k).ColumnWidth 'largeurs des colonnes
                    Next
                    P.Rows(1).Copy .Cells(1)
                End With
            End If
            d(x) = d(x) + 1
            lig = d(x) + 1
            P.Rows(i).Copy Sheets(x).Cells(lig, 1)
            With Sheets(x).Cells(lig, 1).Resize(, ncol).Interior
                If lig Mod 2 Then .ColorIndex = xlNone Else .Color = RGB(221, 235, 247) 'bleu clair
            End With
        End If
Next j, i
F.Activate
End Sub
A+
Cliquez pour agrandir...
Merci beaucoup :)
 
Vote positif 0 Vote négatif
S

SAMESS

XLDnaute Nouveau
Bonjour job75
Comment vas-tu?
tu peux ajouter une autre petite partie ?
si la colonne H de chaque prof contient des doublent,le fichier de la prof sera supprimé et un msg d’erreur qui contient"il faut modifié le planning de la prof "le nom de prof")
si possible!
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour SAMESS, le forum,

Sur le fichier que j'ai joint il y a des doublons de dates dans 5 feuilles sur 6.

Dites-nous comment il faudrait modifier la feuille "Planning".

En effet ça ne sert à rien de balancer des messages dans la nature si l'on ne dit pas ce qu'il faut faire.

A+
 
Vote positif 0 Vote négatif
S

SAMESS

XLDnaute Nouveau
job75 à dit:
Bonjour SAMESS, le forum,

Sur le fichier que j'ai joint il y a des doublons de dates dans 5 feuilles sur 6.

Dites-nous comment il faudrait modifier la feuille "Planning".

En effet ça ne sert à rien de balancer des messages dans la nature si l'on ne dit pas ce qu'il faut faire.

A+
Cliquez pour agrandir...
Bonjour job75,le forum,
il affiche seulement la feuille qui n'est pas contient des doublent et pour les autres au lieu d'affiché un msg erreur, il regroupes toutes les plannings des profs qui contient des doublent dans une seule feuille
si possible!
merci d'avance :)
 
Vote positif 0 Vote négatif

Discussions similaires

chaelie2015
  • Résolu(e)
XL 2013 (RESOLU) Renvoie d'une valeur numérique
Réponses
2
Affichages
102
chaelie2015
chaelie2015
L
  • Question
XL 2021 recherche de valeurs
Réponses
3
Affichages
153
sylvanu
sylvanu
chaelie2015
  • Résolu(e)
XL 2013 (RESOLU) Automatisation Copie Lignes Feuilles selon leurs nom
Réponses
10
Affichages
230
chaelie2015
chaelie2015
S
  • Résolu(e)
Autres Copier-Coller en recherchant une ligne spécifique VBA
Réponses
4
Affichages
290
sambio2
S
C
  • Question
Microsoft 365 Bouton VBA
Réponses
4
Affichages
188
camille37
C
C
  • Résolu(e)
XL 2019 Copier et renommer (en même temps) des feuilles à partir d'une liste de noms dans un colonne
Réponses
13
Affichages
610
Clemee61
C
F
  • Résolu(e)
Microsoft 365 Copier juste couleur cellule.
Réponses
7
Affichages
311
Francky79
F
D
  • Question
XL 2016 Doublons
Réponses
6
Affichages
490
dav59
D
halecs93
  • Résolu(e)
XL 2016 Copie transposée de planning
2
Réponses
24
Affichages
421
job75
job75
R
  • Résolu(e)
XL 2021 Macro copier-coller colonnes précédentes
Réponses
12
Affichages
376
Retraite
R

Membres actuellement en ligne

9 membres et 90 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 215
Messages
2 086 325
Membres
103 179
dernier inscrit
BERSEB50