Feuil et nom

Version imprimable

Feuil et nom

Bonjour a tous,

Je suis en train de faire l'automatisation d'une base de données d’un fichier Excel, mais j’un problème.
La macro dans mon fichier Excel cherche tous les fichiers *.XLS dans un répertoire, après elle écrit l'adresse et après elle ouvre le premier fichier.
Mon problème c'est que je veux que ma macro me dit combien il y a de feuilles dans ce fichier Excel et aussi copie le nom de chaque feuille dans une colonne de ce fichier.

Voici le code de ma macro :

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
41
42
43
44
45
46
47
48
49
50
Sub CHERCHER()
 
'elimina los datos de la busqueda anterior
Cells.Select
Selection.ClearContents
Selection.Interior.ColorIndex = xlNone
 
With Application.FileSearch
    .NewSearch
    .LookIn = "F: \DESSINS"
    .SearchSubFolders = False
    .Filename = "*.XLS"
    .FileType = msoFileTypeAllFiles
    If .Execute() > 0 Then
        MsgBox "Il y a " & .FoundFiles.Count & _
        " fichiers(s) trouves."
        For i = 1 To .FoundFiles.Count
            Range("a" & i).Select
            ActiveCell.FormulaR1C1 = .FoundFiles(i)
            Range("b" & i).Select
            ActiveCell.FormulaR1C1 = "=HYPERLINK(RC[-1],""FICHIER"")"
            Range("b" & i).Select
 
            'abre el primer archivo encontrado
            Workbooks.Open Filename:=.FoundFiles(i)
            ActiveWindow.Visible = True
 
            'Cambia a la primera hoja del archivo
            Worksheets(1).Activate
            Sheets(1).Select
 
 
            'Muestra el nombre de la primera hoja
            'MsgBox ActiveCell.Worksheet.Name
            Windows("EXPERIMENTO.xls").Activate
            Range("c" & i).Activate
            ActiveSheet.Paste
            Windows("EXPERIMENTO.xls").ActivatePrevious
 
 
            'la siguiente linea cierra el archivo *.XLS
            ActiveWindow.Close
 
 
        Next i
    Else
        MsgBox "Il n'y a pas fichier Excel, le dossier c'est pas correct."
    End If
End With
End Sub

Merci beacoup a tous

Bonjour,

Après avoir activé ton premier classeur qui a été trouvé, il suffit d'un

Code:

Sheets.count

pour trouver le nombre de feuilles qu'il y a dedans.

Après, en ce qui concerne le nom de ces feuilles, tu peux faire :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 Sub test() Dim Sht As Worksheet Dim i As Integer i = 1 For Each Sht In ActiveWorkbook.Worksheets Workbooks("BlaBla").Worksheets("Feuil1").Cells(1, i).Value = Sht.Name i = i + 1 Next End Sub
Et voilà.

Bonne journée !

EDIT : pense au balises :tagcode: Sinon, c'est vraiment indigeste :cry: En ce qui concerne ce que je viens de te proposer, le nom des feuilles est copié dans le classeur "BlaBla", dans la feuille "Feuil1". A toi d'adapter.

02/06/2009, 14h18
sergio_gr66

Merci mais j'ai une autre question

Salut Dead78, merci ça marche

est ce que c'est possible d'afficher dans la colonne C par exemple 1,si il trouve dans feuille (trouvé avant) le nom TOTO1 (ou 1 si il trouve TOTO2 ou TOTO3), 2 si il trouve TOTO1 et TOTO2 ou,...3 TOTO1 et TOTO2 et TOTO3,

Re,

Ben de rien. Pour la remarque seconde, c'est possible. Bref, disons que tu veux ton résultat dans la cellule C1.

Tu peux mettre quelque chose dans le goût :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Sub test() Dim cpt As Integer cpt = 0 For i = 1 To Sheets.Count If Cells(1, i).Value = "Toto1" Or Cells(1, i).Value = "Toto2" Or Cells(1, i).Value = "Toto1" Then cpt = cpt + 1 End If Next Range("C1").Value = cpt End Sub
Bonne aprèm !

Bonjour,
excuse moi, mais je ne puex pas faire marcher le denier chose, je te montre le code:

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
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
Sub CHERCHER()
 
'elimina los datos de la busqueda anterior
Cells.Select
Selection.ClearContents
Selection.Interior.ColorIndex = xlNone
 
'Elimina la configuracion de las fuentes
Cells.Select
Selection.Font.Bold = True
Selection.Font.Bold = False
 
 
 
With Application.FileSearch
    .NewSearch
    .LookIn = "F:\DESSINS"
    .SearchSubFolders = False
    .Filename = "*.XLS"
    .FileType = msoFileTypeAllFiles
    If .Execute() > 0 Then
        MsgBox "Il y a " & .FoundFiles.Count & _
        " fichiers(s) trouves."
        For i = 1 To .FoundFiles.Count
            Range("a" & i).Select
            ActiveCell.FormulaR1C1 = .FoundFiles(i)
            Range("b" & i).Select
            ActiveCell.FormulaR1C1 = "=HYPERLINK(RC[-1],""FICHIER"")"
            Range("b" & i).Select
 
            'abre el primer archivo encontrado
            Workbooks.Open Filename:=.FoundFiles(i)
            ActiveWindow.Visible = True
 
            'Cambia a la primera hoja del archivo
            Worksheets(1).Activate
 
            Dim Sht As Worksheet
            Dim a As Integer
 
            a = 4
 
            For Each Sht In ActiveWorkbook.Worksheets
            Workbooks("EXPERIMENTO.xls").Worksheets("Feuil1").Cells(i, a).Value = Sht.Name
            a = a + 1
            '_________________________
            
 
            Dim cpt As Integer
            cpt = 0
            For a = 4 To Sheets.Count
                If Cells(i, a).Value = "Datas" Then
                    cpt = cpt + 1
                End If
                Next
                    Range("c" & i).Value = cpt
 
 
            '_________________________
            Next
 
            Windows("EXPERIMENTO.xls").ActivatePrevious
 
 
            'la siguiente linea cierra el archivo *.XLS
            ActiveWindow.Close
 
        Next i
    Else
        MsgBox "Il n'y a pas fichier Excel, le dossier c'est pas correct."
    End If
 
 
        'Inserta 3 lineas para agregar los titulos a las columnas
        Rows("1:3").Select
        Selection.Insert Shift:=xlDown
        Range("A12").Select
        ActiveSheet.Shapes("Button 1").Select
        Rows("3:3").Select
 
End With
    'agrega los nombres a las columnas y sus caracteristicas
    Selection.Font.Bold = True
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "ADRESSE"
    Range("B3").Select
    ActiveCell.FormulaR1C1 = "HYPER LIEN"
    Range("D3").Select
    ActiveCell.FormulaR1C1 = "FEUILLES DANS LES FICHIERS -->"
 
 
 
    Range("D3").Select
    Cells.Select
    Cells.EntireColumn.AutoFit
 
 
 
End Sub

merci

:ccool:

02/06/2009, 17h58
DeaD78
Re,

N'imbrique pas les 2 morceaux de code que je t'ai donnés et ça devrait marcher.

En gros, tu devrais avoir :
Code:

1 2 3 4 5 6 For '1er code Next For '2ème code Next
De plus, n'utilise pas a comme itérateur pour le 2ème code si tu l'as déjà utilisé pour le 1er. Sait-on jamais, je fais ça par habitude. Appelle-le autrement :zoubi:

Dis-moi si ça marche :ccool:
03/06/2009, 11h17
sergio_gr66

Bonjour, et merci pour tout votre aide,
mais je ne peux pas faire la macro marcher, excel me montre: erreur de compilation: next sans for
03/06/2009, 11h42
aalex_38

Code:

next sans for

Regardes ton code ou montres le nous, ce message apparait si tu ne termine pas une instruction dans le code, par exemple un IF sans END IF

solution

Bonjour,
j'ai trouvé la solution avec ton aide, je te montre le code:

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
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
Sub CHERCHER()
 
'elimina los datos de la busqueda anterior
Cells.Select
Selection.ClearContents
Selection.Interior.ColorIndex = xlNone
 
'Elimina la configuracion de las fuentes
Cells.Select
Selection.Font.Bold = True
Selection.Font.Bold = False
 
 
 
With Application.FileSearch
    .NewSearch
    .LookIn = "c:\DESSINS"
    .SearchSubFolders = True
    .Filename = "*.XLS"
    .FileType = msoFileTypeAllFiles
    If .Execute() > 0 Then
        MsgBox "Il y a " & .FoundFiles.Count & _
        " fichiers(s) trouves."
        For i = 1 To .FoundFiles.Count
            Range("a" & i).Select
            ActiveCell.FormulaR1C1 = .FoundFiles(i)
            Range("b" & i).Select
            ActiveCell.FormulaR1C1 = "=HYPERLINK(RC[-1],""FICHIER"")"
            Range("b" & i).Select
 
            'abre el primer archivo encontrado
            Workbooks.Open Filename:=.FoundFiles(i)
            ActiveWindow.Visible = True
 
            'Cambia a la primera hoja del archivo
            Worksheets(1).Activate
 
            Dim Sht As Worksheet
            Dim a As Integer
            a = 4
            '&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
            Dim cpt As Integer
            cpt = 0
            '&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
            For Each Sht In ActiveWorkbook.Worksheets
            Workbooks("EXPERIMENTO.xls").Worksheets("Feuil1").Cells(i, a).Value = Sht.Name
            '__________________________________
            '__________________________________
 
            If Workbooks("EXPERIMENTO.xls").Worksheets("Feuil1").Cells(i, a).Value = "Datas" Or Workbooks("EXPERIMENTO.xls").Worksheets("Feuil1").Cells(i, a).Value = "amd" Or Workbooks("EXPERIMENTO.xls").Worksheets("Feuil1").Cells(i, a).Value = "gravure" Or Workbooks("EXPERIMENTO.xls").Worksheets("Feuil1").Cells(i, a).Value = "data" Or Workbooks("EXPERIMENTO.xls").Worksheets("Feuil1").Cells(i, a).Value = "datas" Then
                cpt = cpt + 1
                Windows("EXPERIMENTO.xls").Activate
                Range("c" & i).Select
                ActiveCell.FormulaR1C1 = cpt
            End If
            '__________________________________
            '__________________________________
 
            a = a + 1
            Next
            Windows("EXPERIMENTO.xls").ActivatePrevious
            'la siguiente linea cierra el archivo *.XLS
            ActiveWindow.Close
            Next i
    Else
        MsgBox "Il n'y a pas fichier Excel, le dossier c'est pas correct."
    End If
 
 
        'Inserta 3 lineas para agregar los titulos a las columnas
        Rows("1:3").Select
        Selection.Insert Shift:=xlDown
        Range("A12").Select
        ActiveSheet.Shapes("Button 1").Select
        Rows("3:3").Select
 
End With
    'agrega los nombres a las columnas y sus caracteristicas
    Selection.Font.Bold = True
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "ADRESSE"
    Range("B3").Select
    ActiveCell.FormulaR1C1 = "HYPER LIEN"
    Range("D3").Select
    ActiveCell.FormulaR1C1 = "FEUILLES DANS LES FICHIERS -->"
    Range("D3").Select
    Rows("3:3").Select
    Cells.EntireColumn.AutoFit
    Selection.AutoFilter
 
End Sub

Merci beacoup a tous!!!!!
:lol:8-):zoubi:

03/06/2009, 13h47
sergio_gr66

Une autre question, mais c'est dans le même sujet

Bonjour:

est ce que c'est possible de faire macro pour ouvrir automatiquement les fichier ou il trouve les 3 toto(1,2,3) et qu'il copie toutes les lignes qui existent dans ces fichiers mais pas toutes les colonnes (depuis colonne A jusqua colonne G)??
Mais les fichiers ont different quantité de lignes, et je besoin qu'il sélectionne solemment les lignes depuis 2 jusqua il ne trouve plus de data.

Merci a tous pour votre atention
03/06/2009, 14h41
aalex_38

Pour te positionner sur la dernière ligne :

Code:

Range("A65536").End(xlUp)
03/06/2009, 16h53
casefayere

Bonjour alex, sergio, re le forum
pour la derniere ligne, tu peux aussi

Code:

range("a" & rows.count).end(xlup).row

l'avantage, c'est que excel 2007 peut aussi l'utiliser avec ses 1000000 de lignes

bonne fin de journée