application d'une macro a tous les fichiers d'un dossier

Version imprimable

Bonjour
Je suis en ce moment stagiaire et je dois analyser des centaines de fichier excel.Ces fichier excel contiennent plusieurs mesures dont je dois faire la moyenne.Le macro que j'ai fait pour un fichier donne ça:

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
Sub Macro1()
'
   Application.Left = 328
    Application.Top = 220
    Columns("A:A").Select
    Application.Left = 178.75
    Application.Top = 52.75
    Application.WindowState = xlMaximized
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
        Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
        ), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
        (20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1)) _
        , TrailingMinusNumbers:=True
 
    ActiveWindow.SmallScroll Down:=2
    Range("C114").Select
    ActiveCell.FormulaR1C1 = "=AVERAGE(R[-110]C:R[-1]C)"
    Selection.AutoFill Destination:=Range("C114:Y114"), Type:=xlFillDefault
    Range("C114:Y114").Select
 
    Range("C116").Select
    ActiveCell.FormulaR1C1 = "=AVERAGE(R[-2]C,R[-2]C[6],R[-2]C[12])"
    Selection.AutoFill Destination:=Range("C116:H116"), Type:=xlFillDefault
    Range("C116:H116").Select
 
    Range("C116:F116").Select
    Selection.Copy
    Windows("Macr.xls").Activate
    Range("D2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Windows(".CSV").Activate
 
    Range("B1").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Macr.xls").Activate
    Range("B2").Select
    ActiveSheet.Paste
    Windows(".CSV").Activate
    Range("F1").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Macr.xls").Activate
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Windows(".CSV").Activate
 
    Range("H116").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Macr.xls").Activate
    Range("C2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Rows("2:2").Select
    Application.CutCopyMode = False
    Selection.Insert Shift:=xlDown
    Range("A1:A8").Select
    Range("A8").Activate
End Sub

Je precise que les noms de fichier change.
merci d'avoir lu mon message et j'ai vraiment besoin d'aide car franchement j'ai pas d'idée.

25/04/2012, 21h00
Daranc

remet ton code dans les balises idoine c'est le # qu'il faut cliquer. Soit tu le fait avant de coller le code , soit tu sélectionnes ton code posé et tu cliques
25/04/2012, 22h41
kiki29

Salut, voir ici et adapter à ton contexte.
25/04/2012, 23h56
kiki29

Re, de quel type de fichiers s'agit-il : xls, csv, texte tabulé ?
quel extension porte ces fichiers et quel séparateur est utilisé ?
J'ai une solution ( non récursive ) plus simple que celle préconisée plus haut.

Il te restera à ajouter les formules pour les moyennes etc...
26/04/2012, 19h41
muisca

Salut
c'est des fichier csv eet pour obtenir mes donnes je dois la convertir.le separateur est la tabulation. si tu peu m'aider ca serai cool car la je souffre

Salut, à tester

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
Option Explicit
 
Private Sub ConcatenationCSV(sDossier As String)
Dim Wkb As Workbook
Dim sChemin As String, sFichier As String
Dim LastRow As Long, iRow As Long
Dim c As Range, Ar() As String
Const sSeparateur As String = vbTab
 
    Application.ScreenUpdating = False
 
    sChemin = sDossier & "\"
    sFichier = Dir$(sChemin & "*.csv")
 
    Feuil1.Cells.Clear
    Do While Len(sFichier) > 0
 
        Set Wkb = Workbooks.Open(sChemin & sFichier)
        LastRow = Wkb.Sheets(1).Cells(Wkb.Sheets(1).Rows.Count, 1).End(xlUp).Row
 
        With Feuil1
            For Each c In Wkb.Sheets(1).Range("A1:A" & LastRow)
                iRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                Ar = Split(c, sSeparateur)
                .Range(.Cells(iRow, 1), .Cells(iRow, UBound(Ar) + 1)).Value = Ar
            Next c
        End With
 
        Wkb.Close
        Set Wkb = Nothing
 
        sFichier = Dir$()
    Loop
    Application.ScreenUpdating = True
End Sub
 
Sub SelDossierCSV()
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "Dossier à traiter"
        .AllowMultiSelect = False
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            DoEvents
            ConcatenationCSV .SelectedItems(1)
        End If
    End With
End Sub

2 pièce(s) jointe(s)

vraiment dsl d'avoir pas répondu avant mais au cours de ce mois je devais bosser mes exams

Je te remercie encore pour ta macro mais il y a un léger bug
en fait j'ai crée une macro qui marche a moitié vu que la séparation se fait à moitié
Voila la 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
Sub SupprLignes() 'les 16 premières lignes
Dim i%, NbC%, Chemin$, NomFichier$
 
    Chemin = ActiveWorkbook.Path & "\"
    Application.ScreenUpdating = False
    NbC = Range("A65536").End(xlUp).Row
 
        For i = 5 To NbC
            NomFichier = Cells(i, 1)
            Workbooks.Open Filename:=Chemin & NomFichier
            Columns("A:A").Select
        Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
        Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
        ), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array _
        (20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1)) _
        , TrailingMinusNumbers:=True
            ActiveWorkbook.Save
            ActiveWorkbook.Close
        Next i
End Sub
Sub ListeFichiers() 'liste les fichiers du répertoire
Dim Chemin$, FName$, Wbk$
    '-- Liste les fichiers du répertoire sauf celui-ci --
    Wbk = ActiveWorkbook.Name
    Range("a5:a1000").Clear
    Chemin = ActiveWorkbook.Path & "\"
        FName = Dir(Chemin & "*.csv")
    Do While FName <> ""
        If FName <> Wbk Then Range("a65536").End(xlUp)(2) = FName
        FName = Dir
    Loop
End Sub

dans le fichier compressé j'ai mis le fichier cs a convertir et la macro qui devrait le faire
J'ai mis aussi le fichier final que j'aimerai obtenir

merci d'avoir lu mon message

Salut, bref tes fichiers sont des fichiers que l'on appelle texte tabulé et non csv et l'extension devrait être txt.

Sur une feuille avec CodeName ShParam
Affecter un bouton à SelDossier
Affecter un bouton à DelFeuilles
Affecter un bouton à ConcatenationFeuilles

Dans un Module Standard

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
Option Explicit
 
Dim Nb As Long, NbLus As Long
Const sTypeFichier As String = "csv"
Const sSeparateur As String = vbTab
 
Sub DelFeuilles()
Dim i As Long
    Application.DisplayAlerts = False
    For i = Sheets.Count To 1 Step -1
        If Sheets(i).Name <> ShParam.Name And Sheets(i).Name <> ShConcat.Name Then
            Sheets(i).Delete
        End If
    Next i
    Application.DisplayAlerts = True
End Sub
 
Private Function Extension(sFichier As String) As String
Dim sExt As String
    sExt = Mid$(sFichier, InStrRev(sFichier, ".") + 1)
    Extension = sExt
End Function
 
Private Sub Lire(ByVal sNomFichier As String)
Dim sChaine As String
Dim Ar() As String
Dim i As Long
Dim iRow As Long, iCol As Long
Dim NumFichier As Integer
Dim Ws As Worksheet
 
    Close
 
    NumFichier = FreeFile
    iRow = 1
 
    Open sNomFichier For Input As #NumFichier
    Set Ws = ThisWorkbook.Sheets.Add
    Ws.Move After:=Worksheets(Sheets.Count)
    Do While Not EOF(NumFichier)
        iCol = 1
        Line Input #NumFichier, sChaine
        Ar = Split(sChaine, sSeparateur)
        For i = LBound(Ar) To UBound(Ar)
            Ws.Cells(iRow, iCol) = Ar(i)
            iCol = iCol + 1
        Next i
        iRow = iRow + 1
    Loop
    Close #NumFichier
End Sub
 
Private Sub ListeFichiers(sDossier As String)
Dim sFichier As String, sChemin As String
Dim sExtension As String
 
    sFichier = Dir$(sDossier & "\*." & sTypeFichier)
    Do While Len(sFichier) > 0
        sChemin = sDossier & "\" & sFichier
        sExtension = Extension(sChemin)
        Nb = Nb + 1
        If UCase$(sExtension) = UCase$(sTypeFichier) Then
            NbLus = NbLus + 1
            Lire sChemin
        End If
        Application.StatusBar = NbLus & " / " & Nb
        sFichier = Dir$()
    Loop
End Sub
 
Sub SelDossier()
Dim sChemin As String
 
    sChemin = ThisWorkbook.Path
 
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sChemin & "\"
        .Title = "Sélectionner le Dossier"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            Nb = 0
            NbLus = 0
            Application.ScreenUpdating = False
            ListeFichiers .SelectedItems(1)
            With ShParam
                .Activate
                .Range("A1").Select
            End With
            Application.ScreenUpdating = True
        End If
    End With
End Sub

Insérer une autre feuille avec CodeName ShConcat
Dans un autre Module Standard

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Option Explicit
 
Sub ConcatenationFeuilles()
Dim i As Long
Dim T() As Variant
    QueryPerformanceCounter Debut
    Application.ScreenUpdating = False
    ShConcat.Cells.Clear
    For i = 1 To Sheets.Count
        If Sheets(i).Name <> ShParam.Name And Sheets(i).Name <> ShConcat.Name Then
            With Sheets(i)
                T = .Range("A1:Y" & .Range("A" & Rows.Count).End(xlUp).Row).Value
                ShConcat.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(T, 1), UBound(T, 2)) = T
            End With
        End If
    Next i
    ShConcat.Columns("A:A").NumberFormat = "hh:mm:ss"
 
    Erase T
    Application.ScreenUpdating = True
End Sub

24/05/2012, 19h59
muisca

1 pièce(s) jointe(s)

merci c'est parfait ça marche parfaitement
j'ai juste une dernier question a te poser. J'ai crée une macro qui va me permettre de mieux organisé mes données.
si dans la colonne de A n est égale a 10
B n est copié dans un fichier excel 1
C n est copié dans un fichier excel 1
A n+100 est copié dans un fichier excel 1
et encore merci
24/05/2012, 20h53
kiki29

Re, via l'enregistreur de macros, tu crées un filtre auto puis tu copies ce bloc de valeurs sur la feuille idoine
24/05/2012, 21h36
muisca

Re
merci de repondre si vite voila j'ai essaye de faire ce que tu m'as dit
mais ça ne marche pas.il me dise que la selection autofilter a echoué
et franchement la je constate que je te demande beaucoup donc si tu peux pas c'est pas grave

Salut, un exemple vite fait à adapter à ton contexte

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
Option Explicit
 
Sub Tst()
Dim LastRow As Long
 
    LastRow = Feuil1.Range("A" & Rows.Count).End(xlUp).Row
 
    With Feuil1
        .AutoFilterMode = False
        '  En-tête
        .Range("A1:C1").AutoFilter
        Selection.AutoFilter Field:=1, Criteria1:="10"
    End With
 
    With Feuil2
        .Cells.Clear
        '  Données sous l'en-tête
        Feuil1.Range("A2:C" & LastRow).SpecialCells(xlCellTypeVisible).Copy _
                Destination:=.Range("A1")
    End With
 
    With Feuil1
        .AutoFilterMode = False
        .Range("A1:C1").AutoFilter
    End With
 
    Application.CutCopyMode = False
End Sub

25/05/2012, 20h14
muisca

slt je te remercie de l'aide que tu m'as apporté mais j'ai troué un autre moyen pour faire ce que je voulais
bonne soirée et franchement tu es doué