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

Version imprimable

21/04/2011, 10h17
pouet35

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 !

Bonjour,
J'ai essayé de vous faire une macro. Je ne sais pas si c'est exactement ce que vous recherchiez. Bonne chance

Code:

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

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:

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é.