IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Macros et VBA Excel Discussion :

Créer un onglet en fonction du contenu d'une colonne


Sujet :

Macros et VBA Excel

  1. #1
    Candidat au Club
    Inscrit en
    Février 2011
    Messages
    3
    Détails du profil
    Informations forums :
    Inscription : Février 2011
    Messages : 3
    Points : 3
    Points
    3
    Par défaut Créer un onglet en fonction du contenu d'une colonne
    Bonjour,

    J'ai une colonne contenant des noms de fichiers divers : xls, doc, jpg.

    je souhaiterais faire une macro qui me copie dans un onglet spécifique ces fichiers en fonction de leur extension : créer un onglet DOC pour les documents word, etc...

    merci pour votre aide, je cale un peu !

  2. #2
    Membre du Club Avatar de smacksime
    Homme Profil pro
    Inscrit en
    Avril 2011
    Messages
    17
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Doubs (Franche Comté)

    Informations forums :
    Inscription : Avril 2011
    Messages : 17
    Points : 43
    Points
    43
    Par défaut
    Bonjour,
    J'ai essayé de vous faire une macro. Je ne sais pas si c'est exactement ce que vous recherchiez. Bonne chance
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    Sub Ta_macro()
     
    'en supposant que vos noms de format sont dans la colonne A de la feuille nommée "Feuil1", sinon, il vous faut adapter le code suivant
     
        Dim format As String
     
        derniere_ligne = Workbooks(ActiveWorkbook.Name).Sheets("Feuil1").Range("a65536").End(xlUp).Row
        For i = 1 To derniere_ligne
            For j = 1 To Len(Workbooks(ActiveWorkbook.Name).Sheets("Feuil1").Range("A" & i))
                car = Right(Workbooks(ActiveWorkbook.Name).Sheets("Feuil1").Range("A" & i), j)
                If Left(car, 1) = "." Then
                    Exit For
                End If
            Next
            format = Right(Workbooks(ActiveWorkbook.Name).Sheets("Feuil1").Range("A" & i), j - 1)
            MsgBox Right(Workbooks(ActiveWorkbook.Name).Sheets("Feuil1").Range("A" & i), j - 1)
            nouvelle_feuille = 1
            For k = 1 To Sheets.Count
                If Sheets(k).Name = format Then
                    nouvelle_feuille = 0
                    Exit For
                End If
            Next
            If nouvelle_feuille = 1 Then
                Dim feuille As Worksheet
                Set feuille = Sheets.Add(After:=Sheets(Sheets.Count))
                Sheets(Sheets.Count).Name = format
                Sheets(format).Range("A1") = Sheets("Feuil1").Range("A" & i)
            Else
                dernière_ligne2 = Sheets(format).Range("A65536").End(xlUp).Row + 1
                Sheets(format).Range("A" & dernière_ligne2) = Workbooks(ActiveWorkbook.Name).Sheets("Feuil1").Range("A" & i)
            End If
        Next
    End Sub

  3. #3
    Expert éminent
    Homme Profil pro
    Inscrit en
    Août 2010
    Messages
    3 453
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France

    Informations forums :
    Inscription : Août 2010
    Messages : 3 453
    Points : 6 871
    Points
    6 871
    Par défaut
    Bonsoir,

    Est-ce que ceci ferait l'affaire ?
    Je n'est pas géré les nouvelles extensions du type .xlsx et autres mais si c'est nécessaire reviens :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
     
    Sub Extension()
     
        Dim Fe As Worksheet
        Dim Plage As Range
        Dim Cel As Range
        Dim Ext As String
        Dim DerLigne As Long
     
        'la plage des noms de fichiers est en colonne A
        Set Plage = Range([A1], [A65536].End(xlUp))
     
        For Each Cel In Plage
     
            'gère l'erreur si la feuille est inexistante
            On Error Resume Next
            Set Fe = Worksheets(Right(Cel, 3))
     
            If Err.Number <> 0 Then
     
                'la crée si elle n'existe pas
                Set Fe = Worksheets.Add
     
                'la renomme avec l'extension
                Fe.Name = Right(Cel, 3)
     
                'inscrit le premier fichier en A1
                Fe.[A1] = Cel
     
            'si la feuille existe déjà
            Else
     
                'recherche la ligne vide en colonne A et inscrit le nom du fichier
                Fe.Range("A" & Fe.[A65536].End(xlUp).Offset(1, 0).Row) = Cel
     
            End If
     
        Next Cel
     
    End Sub
    Hervé.

Discussions similaires

  1. [XL-2003] Création d'onglets en fonction du résultat d'une colonne
    Par BAYRAL dans le forum Macros et VBA Excel
    Réponses: 1
    Dernier message: 15/02/2011, 17h37
  2. Suppression d'une ligne en fonction du contenu d'une case
    Par Iloon dans le forum Macros et VBA Excel
    Réponses: 6
    Dernier message: 18/06/2008, 14h43
  3. Réponses: 2
    Dernier message: 29/08/2007, 11h55
  4. [VBA-E] Lancement d'une macro en fonction du contenu d'une cellule
    Par Zak Blayde dans le forum Macros et VBA Excel
    Réponses: 5
    Dernier message: 30/01/2007, 16h13
  5. Réponses: 18
    Dernier message: 27/10/2006, 15h15

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo