Discussion :

[Phil_57]

Bonjours à tous,
Je suis nouveau sur ce Forum et je remercie par avance les personnes qui prendrons le temps de se pencher sur mon problème.
Je souhaite réaliser un tableau de synthèse de fichiers Excel correspondant à des devis. Chaque devis est enregistré sous son numéro de référence. Le premier devis de l’année est enregistré sous le numéro 1, le deuxième sous 2, etc... Cela peut aller jusqu’a 8000 ou 9000 en fin d’année.
Ce tableau de synthèse serais enregistré dans le même répertoire que les devis et permettrait d’obtenir une synthèse de devis par ligne en fonction du numéro d’enregistrement colonne A.
Exemple:
A B C D E F G
1 Devis Client Sujet Tél Fax E-mail etc...
2 1
3 2
4 3
5 etc...

Le numéro de devis colonne A peut être rempli manuellement ou pré-rempli.

Peut-on utiliser le fontion RECHERCHEV (VLOOKUP) et faire varier le nom du fichier de référence ou exist-il une autre solution?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

=VLOOKUP(A2;'C:\EAA\EAA Quotes\[1.xlsm]Quotation'!$3:$3;3;0)

En espérant avoir des réponses.

A bientôt.

Phil.

[Philippe Tulliez]

Bonjour,
Comment sont organisées les données des devis ?
Un devis = un classeur ?
etc.

[Phil_57]

Bonjour,
Comment sont organisées les données des devis ?
Un devis = un classeur ?
etc.

Bonjour,

Il y a un classseur par devis et l'ensemble des informations à récupérer se trouvent sur une seule feuille.
Chaque classeur est enregistré sous le numéro de devis (1, 2, 3, ..., 6000, ...).

Les données comme le client, le Tél, le prix, etc... sont réparties à plusieurs endroits sur la feuille mais je peux renvoyer l'ensemble de ces infos sur une ligne cachée si nécessaire.

Merci pour votre aide.

[kiki29]

Salut; peut-être commencer par lire ceci

[Phil_57]

Salut; peut-être commencer par lire ceci

Merci.

Je vais regarder si je peux y trouver mon bonheur.

[kiki29]

re, il te faudra également une liste des fichiers ( récursive ou non ) via FSO ou APIs (x3 plus rapide que FSO surtout si beaucoup de fichiers )

[kiki29]

Salut, je viens de sortir ceci des décombres en l'allégeant

Affecter un bouton à btnImport_QuandClic
Adapter à ton contexte cette partie

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
Const DossierFichiers = "C:\Faq\Faq Vba\Exemples\Lecture Donnees\FF"
Const NomFeuille As String = "Offre de Prix"
Const TypeFichier As String = "XLS"
Const NomFichierRch = "FF+COXX*"

Ainsi que celle-ci :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
            .Cells(NumeroLigne, 4) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "E14")
            .Cells(NumeroLigne, 5) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "O14")
            .Cells(NumeroLigne, 6) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "C16")
            .....

Et la procédure EnteteImport
Il reste sans doute des scories à supprimer, modifier ...
La liste des fichiers ne fait pas appel à une procédure FSO récursive.

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
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
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
Option Explicit
 
Dim NbFichiers As Long
Dim DossierOk As String
 
Const DossierFichiers = "C:\Faq\Faq Vba\Exemples\Lecture Donnees\FF"
Const NomFeuille As String = "Offre de Prix"
Const TypeFichier As String = "XLS"
Const NomFichierRch = "FF+COXX*"
 
Sub btnImport_QuandClic()
Dim Debut As Variant
Dim NumeroLigne As Long, i As Long
Dim NomFichier As String
 
    ' Par curiosité
    Debut = Time()
    Application.ScreenUpdating = False
    EnteteImport
    NomDossierOk
    ListeFichiersDans DossierOk
 
    ' E14 014 C16 C19 D11 N11 F35 F43
    ' On démarre le remplissage de ShImport à cette ligne
    NumeroLigne = 4
 
    For i = 1 To NbFichiers
        NomFichier = ShImport.Range("A" & NumeroLigne)
        With ShImport
            .Cells(NumeroLigne, 4) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "E14")
            .Cells(NumeroLigne, 5) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "O14")
            .Cells(NumeroLigne, 6) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "C16")
            .Cells(NumeroLigne, 7) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "C19")
            .Cells(NumeroLigne, 8) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "D11")
            .Cells(NumeroLigne, 9) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "N11")
            .Cells(NumeroLigne, 10) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "F35")
            .Cells(NumeroLigne, 11) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "F43")
        End With
        NumeroLigne = NumeroLigne + 1
        Application.StatusBar = "Lecture Données : " & i & " / " & NbFichiers
    Next
 
    Application.StatusBar = "Terminé : " & Format((Time() - Debut) * 100000, "0.00")
 
    MepImport
    Application.ScreenUpdating = True
End Sub
 
Sub DispoBoutonsImport()
Dim t As Range
    With ShImport
        .Activate
        .Rows(1).RowHeight = 12.75
        .Rows(2).RowHeight = 12.75
 
        Set t = .Cells(1, 3)
        With .Buttons("btnImport")
            .Left = t.Left + 3
            .Top = t.Top + 5
            .Width = t.Width - 6
            .Height = Rows(1).RowHeight + Rows(2).RowHeight - 8
        End With
    End With
End Sub
 
Private Sub EnteteImport()
    With ShImport
        '   Tout effacer
        .Cells.Clear
        .Range("A3") = "Fichier"
        '   A tout hasard cela peut être interessant
        '   d'avoir ces infos sur les fichiers
        .Range("B3") = "Date de Création"
        .Range("C3") = "Date Dernière Modification"
 
        '   E14 014 C16 C19 D11 N11 F35 F43
        .Range("D3") = "Devis"
        .Range("E3") = "Date"
        .Range("F3") = "Société"
        .Range("G3") = "Ville"
        .Range("H3") = "Destinataire"
        .Range("I3") = "Téléphone"
        .Range("J3") = "Total HT"
        .Range("K3") = "Condition Règlement"
    End With
End Sub
 
Private Function ExtraireValeur(ByVal Dossier As String, ByVal fichier As String, _
        ByVal feuille As String, ByVal Cellule As String)
Dim Argument As String
Dim Pos As Integer
    Pos = InStr(Dossier, "'")
    If Pos > 0 Then Dossier = Replace(Dossier, "'", "''")
    Pos = InStr(fichier, "'")
    If Pos > 0 Then fichier = Replace(fichier, "'", "''")
 
    Argument = "'" & Dossier & "[" & fichier & "]" & feuille & "'!" & Range(Cellule).Address(, , xlR1C1)
    ExtraireValeur = ExecuteExcel4Macro(Argument)
End Function
 
Private Sub ListeFichiersDans(ByVal NomDossierSource As String)
Dim FSO As Object
Dim DossierSource As Object
Dim fichier As Object
Dim r As Long, VerifNom As Boolean
Dim Extension As String
    On Error GoTo erreurs
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set DossierSource = FSO.GetFolder(NomDossierSource)
 
    Application.StatusBar = ""
    NbFichiers = 0
    r = ShImport.Range("A" & Rows.Count).End(xlUp).Row + 1
 
    For Each fichier In DossierSource.Files
        Extension = UCase$(FSO.GetExtensionName(fichier))
        If fichier.Name <> ThisWorkbook.Name Then
            VerifNom = fichier.Name Like NomFichierRch
            If VerifNom Then
                If Extension = UCase(TypeFichier) Then
                    With ShImport
                        .Cells(r, 1) = fichier.Name
                        .Cells(r, 2) = fichier.DateCreated
                        .Cells(r, 3) = fichier.DateLastModified
                    End With
                    NbFichiers = NbFichiers + 1
                    r = r + 1
                    Application.StatusBar = "Lecture Noms Dates création et modification fichiers : " & r
                End If
            End If
        End If
    Next fichier
    ' Nommer la zone contenant les données pour faciliter un tri éventuel
    ActiveWorkbook.Names.Add Name:="Zone_de_Tri", RefersToR1C1:="=Import!R4C1:R" & (NbFichiers + 3) & "C11"
 
    Set fichier = Nothing
    Set DossierSource = Nothing
    Set FSO = Nothing
    Exit Sub
erreurs:
    If Err.Number = 76 Then
        MsgBox "Dossier inexistant" & vbCrLf & "Modifier dans VBA le chemin" & vbCrLf & "Const Dossier = " & DossierFichiers & " en conséquence", vbOKOnly, "Dossier des Fichiers"
    End If
End Sub
 
Private Sub MepImport()
    With ActiveWindow
        .ScrollRow = 1
        .ScrollColumn = 1
    End With
 
    With ShImport
        .Rows("3:3").Font.Bold = True
        .Columns("B:C").Select
    End With
 
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
 
    With ShImport
        .Columns("E:E").NumberFormat = "dd/mm/yyyy"
        .Columns("A:K").Columns.AutoFit
        .Range("A1").Select
    End With
 
    DispoBoutonsImport
End Sub
 
Private Sub NomDossierOk()
    DossierOk = DossierFichiers
    If Right$(DossierOk, 1) <> "\" Then DossierOk = DossierOk & "\"
End Sub

[Phil_57]

Merci pour toutes ces infos.
Je vais essayer de bosser tout ça pour en sortir quelque chose.

[kiki29]

Salut, une version avec une recherche récursive ou non. A sauver en xlsb/xlsm

Créer un bouton en la baptisant "btnImport" et l'affecter à "SelDossier"
Créer une Checkbox en la baptisant "chkRecur"

Il faudra l'adapter à ton contexte pour l'import des données souhaitées.
si au final il y 10000 devis, cela te laissera le loisir de prendre le café, car cela s'avèrera long.
à moins que tu ne décomposes par mois et ne fasses une fusion de fin d'année ?
En fait il aurait fallu d'entrée que l'appli soit faite sur une base Access mais là c'est une autre histoire.

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
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
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
Private Declare Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean
 
Option Explicit
Option Base 1
 
Dim NbFichiers As Long
 
Const sNomFeuille As String = "Offre de Prix"
Const TypeFichier As String = "XLS*"
Const sNomFichierRch As String = "FF+COXX*"
 
Sub DispoBoutonsImport()
Dim t As Range
    With ShImport
        .Activate
        .Rows(1).RowHeight = 12.75
        .Rows(2).RowHeight = 12.75
 
        Set t = .Cells(1, 1)
        With .Buttons("btnImport")
            .Left = t.Left + 2
            .Top = t.Top + 2
            .Width = 100
            .Height = Rows(1).RowHeight + Rows(2).RowHeight - 2
        End With
 
        With .Shapes("chkRecur")
            .Left = ShImport.Buttons("btnImport").Left + ShImport.Buttons("btnImport").Width + 5
            .Top = ShImport.Buttons("btnImport").Top + 1
            .Height = 23
            .Width = 100
        End With
        Set t = Nothing
    End With
End Sub
 
Private Sub EnteteImport()
    With ShImport
        .Cells.Clear
        .Range("A3") = "Fichier"
        .Range("B3") = "Date de Création"
        ' nom du dossier ( info temporaire effacée à la  fin )
        .Range("C3") = ""
 
        .Range("D3") = "Devis"
        .Range("E3") = "Date"
        .Range("F3") = "Société"
        .Range("G3") = "Ville"
        .Range("H3") = "Destinataire"
        .Range("I3") = "Téléphone"
        .Range("J3") = "Total HT"
        .Range("K3") = "Condition Règlement"
    End With
End Sub
 
Private Function ExtraireValeur(ByVal sDossier As String, ByVal sFichier As String, _
        ByVal sFeuille As String, ByVal sCellule As String)
Dim Argument As String
Dim Pos As Long
    Pos = InStr(sDossier, "'"): If Pos > 0 Then sDossier = Replace(sDossier, "'", "''")
    Pos = InStr(sFichier, "'"): If Pos > 0 Then sFichier = Replace(sFichier, "'", "''")
    Pos = InStr(sFeuille, "'"): If Pos > 0 Then sFeuille = Replace(sFeuille, "'", "''")
    Argument = "'" & sDossier & "[" & sFichier & "]" & sFeuille & "'!" & Range(sCellule).Address(, , xlR1C1)
    ExtraireValeur = ExecuteExcel4Macro(Argument)
End Function
 
Private Sub Import(sDossier As String)
Dim Debut As Currency, Fin As Currency, Freq As Currency
Dim iLigne As Long, iCol As Long, i As Long, j As Long
Dim sNomFichier As String, sDossierOk As String
Dim TabCoord() As Variant
 
    QueryPerformanceCounter Debut
    Application.ScreenUpdating = False
    EnteteImport
 
    NbFichiers = 0
 
    ' Recherche récursive True/False
    ListeFichiersDans sDossier, ShImport.CheckBoxes("chkRecur").Value = 1
 
    ' Tableau des cellules à balayer
    TabCoord = Array("E14", "O14", "C16", "C19", "D11", "N11", "F35", "F43")
 
    iLigne = 4
    For i = 1 To NbFichiers
        iCol = 4
        sNomFichier = ShImport.Range("A" & iLigne)
        sDossierOk = ShImport.Range("C" & iLigne) & "\"
        With ShImport
            For j = 1 To UBound(TabCoord)
                .Cells(iLigne, iCol) = ExtraireValeur(sDossierOk, sNomFichier, sNomFeuille, TabCoord(j))
                iCol = iCol + 1
            Next j
        End With
        iLigne = iLigne + 1
        Application.StatusBar = "Lecture Données : " & i & " / " & NbFichiers
        DoEvents
    Next i
 
    QueryPerformanceCounter Fin
    QueryPerformanceFrequency Freq
    Application.StatusBar = Application.StatusBar & "   Terminé : " & Format((Fin - Debut) / Freq, "0.00 s")
 
    MepImport
    Application.ScreenUpdating = True
End Sub
 
Private Sub ListeFichiersDans(ByVal sNomDossierSource As String, bInclureSousDossiers As Boolean)
Dim FSO As Object
Dim DossierSource As Object
Dim SousDossier As Object
Dim Fichier As Object
Dim r As Long, VerifNom As Boolean
Dim sExt As String
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set DossierSource = FSO.GetFolder(sNomDossierSource)
 
    Application.StatusBar = ""
 
    r = ShImport.Range("A" & Rows.Count).End(xlUp).Row + 1
 
    For Each Fichier In DossierSource.Files
        sExt = UCase$(FSO.GetExtensionName(Fichier))
        If Fichier.Name <> ThisWorkbook.Name Then
            VerifNom = Fichier.Name Like sNomFichierRch
            If VerifNom And sExt Like UCase$(TypeFichier) Then
                With ShImport
                    .Cells(r, 1) = Fichier.Name
                    .Cells(r, 2) = Fichier.DateCreated
                    .Cells(r, 3) = FSO.GetParentFolderName(Fichier)
                End With
                NbFichiers = NbFichiers + 1
                r = r + 1
                Application.StatusBar = "Liste Fichiers : " & NbFichiers
            End If
        End If
        DoEvents
    Next Fichier
 
    If bInclureSousDossiers Then
        For Each SousDossier In DossierSource.SubFolders
            ListeFichiersDans SousDossier.Path, True
        Next SousDossier
    End If
 
    ActiveWorkbook.Names.Add Name:="Zone_de_Tri", RefersToR1C1:="=Import!R4C1:R" & (NbFichiers + 3) & "C11"
 
    Set Fichier = Nothing
    Set DossierSource = Nothing
    Set FSO = Nothing
End Sub
 
Private Sub MepImport()
    With ActiveWindow
        .ScrollRow = 1
        .ScrollColumn = 1
    End With
 
    With ShImport
        .Rows("3:3").Font.Bold = True
        .Columns("B:C").Select
    End With
 
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
 
    With ShImport
        .Columns("E:E").NumberFormat = "dd/mm/yyyy"
        .Columns("A:K").Columns.AutoFit
        .Columns("C:C").Delete Shift:=xlToLeft
        .Range("D1").Select
    End With
 
    DispoBoutonsImport
End Sub
 
Sub SelDossier()
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "Sélectionner le Dossier à Traiter"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            DoEvents
            Import .SelectedItems(1)
        End If
    End With
End Sub