Lecture classeur ferme - probleme avec entetes

**vanhoa** · 29/03/2017, 13h10

Salut a tous!

J'ai un souci d'entete lorsque je lis un classeur ferme.
J'ai utilise le code fourni dans un tuto de SilkyRoad que j'ai adapte.
Voici le principe, a partir d'un fichier de consolidation, je vais seulement lire et recuperer le contenu des worksheets qui remplissent une condition dans des fichiers qui resteront fermes. Exemple, j'ai 2 fichiers qui sont ferme et qui possedent chacun 10 worksheets, seul 1 seul de ces worksheet m'interesse (celui qui rempli la condition).

Tout marche je recupere le contenu du worksheet que je souhaite, mais le probleme est que les entete ne sont pas toutes recopiees, certaines manquent.
Cela ne vient pas du contenu des entetes car je l'ai ai change pour verifie et ce sont toujours les entetes des memes colonnes qui manquent.

Pour mon code ci-dessous, pas besoin de tout lire car le probleme vient seulement au moment ou je recupere les data et que je les mets dans le worksheet "sh_ToTr", soit dans mon code, la partie ----- recupe data -----
Apres cette partie, c'est pour autre chose

Donc ma question est, pourquoi cela recupere seulement certaines entetes?
Merci pour votre aide!

Voici mon code:

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
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
Option Explicit
Public bo_Stop As Boolean
Sub Consolidate3PLfiles()
Dim i As Long, j As Long, k As Long, m As Long
Dim n_File As Byte, n_Col As Byte, n_yConso As Long, n_yStart As Byte, n_yEnd As Long, n_xEnd As Long, n_DimUpdate As Long
Dim str_Name As String, str_tab As String, tb_strTab() As String
Dim sh_tab As ADOX.Table
Dim tb_Name() As String, tb_KeyWord() As String, tb_Collect() As Byte
Dim tb_iCol() As Byte, tb_str1() As String, tb_str2() As String, tb_str3() As String
Dim tb_TotConso() As Variant, tb_RsltGGC As Variant, tb_ToGGC() As Variant
Dim str_toRead As String
Dim texte_SQL As String
Dim cn_X As ADODB.Connection, Cn2 As ADODB.Connection, oCat As ADOX.Catalog
Dim Rst As ADODB.Recordset
 
    bo_Stop = False
    n_File = sh_Button.Cells(4, 8).End(xlDown).Row - 3 - 1
    n_Col = sh_Data.Cells(1, 1).End(xlDown).Row - 1
    n_yConso = 1
    n_DimUpdate = 0
    ReDim tb_Name(n_File)
    ReDim tb_KeyWord(n_File)
    ReDim tb_Collect(n_File)
    ReDim tb_iCol(n_Col)
    ReDim tb_str1(n_Col)
    ReDim tb_str2(n_Col)
    ReDim tb_str3(n_Col)
 
    For i = 0 To n_File
        tb_Name(i) = sh_Button.Cells(i + 4, 8).Value
        tb_KeyWord(i) = sh_Button.Cells(i + 4, 9).Value
        tb_Collect(i) = sh_Button.Cells(i + 4, 10).Value
    Next i
 
    For i = 0 To n_Col
        tb_iCol(i) = sh_Data.Cells(i + 1, 1).Value
        tb_str1(i) = sh_Data.Cells(i + 1, 2).Value
        tb_str2(i) = sh_Data.Cells(i + 1, 3).Value
        tb_str3(i) = sh_Data.Cells(i + 1, 4).Value
    Next i
 
    Do
        sh_ToTr.Range(sh_ToTr.Columns(1), sh_ToTr.Columns(100)).Delete
    Loop While sh_ToTr.UsedRange.Rows.Count > 1
 
 
    '---------------------------------------------------- boucle sur le nombre de fichiers ----------------------------------------------------
    For i = 0 To n_File
 
        str_tab = ""
        ReDim tb_strTab(tb_Collect(i) - 1)
 
        str_Name = tb_Name(i) & "_" & sh_Button.Cells(4, 4).Value & "_" & sh_Button.Cells(4, 5).Value
        'nom du classeur ferme servant de base de donnees
        str_toRead = "C:\Users\alexandre.delecolle\Desktop\LZD\0-Ops\2-Ad-hoc\test\" & str_Name & ".xlsx"
 
        Set cn_X = New ADODB.Connection
        Set oCat = New ADOX.Catalog
 
        'Debug.Print str_toRead
 
        With cn_X
            .Provider = "Microsoft.Jet.OLEDB.4.0"
            .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
            & str_toRead & ";Extended Properties=""Excel 12.0;HDR=NO;"""
            .Open
        End With
 
        Set oCat.ActiveConnection = cn_X
 
        '---------------------------------------------------- boucle sur le nombre de fichiers ----------------------------------------------------
        For j = 0 To UBound(tb_strTab)
 
            '------------------------------------- A/ condition pour voir quel worksheet on recupere ---------------------------------
            For Each sh_tab In oCat.Tables
                If tb_KeyWord(i) = "Only one sheet" Then
                    tb_strTab(j) = sh_tab.Name
                Else
                    If StrConv(sh_tab.Name, vbLowerCase) Like "*" & StrConv(tb_KeyWord(i), vbLowerCase) & "*" Then
                        tb_strTab(j) = sh_tab.Name
                        If tb_Collect(i) = 1 Then
                            Exit For
                        Else
                            tb_Collect(i) = tb_Collect(i) - 1
                        End If
                    Else
                    End If
                End If
            Next
            '--------------------------------------- fin A/ condition pour worksheet ---------------------------------------
            '-------------------------------------------------- recupe data ------------------------------------------------
            Debug.Print tb_strTab(j)
            texte_SQL = "SELECT * FROM [" & tb_strTab(j) & "]"
            Set Rst = New ADODB.Recordset
            Set Rst = cn_X.Execute(texte_SQL)
 
            sh_ToTr.Cells(1, 1).CopyFromRecordset Rst
            '-------------------------------------------------- fin recupe data ------------------------------------------------
 
            n_xEnd = sh_ToTr.UsedRange.Columns.Count
            n_yEnd = sh_ToTr.UsedRange.Rows.Count
            For k = 1 To n_xEnd
                If sh_ToTr.Cells(sh_ToTr.Rows.Count, k).End(xlUp).Row > n_yEnd Then
                    n_yEnd = sh_ToTr.Cells(sh_ToTr.Rows.Count, k).End(xlUp).Row
                Else
                End If
            Next k
            For k = 1 To n_yEnd
                If FirstRow(tb_iCol, tb_str1, k) = True Then
                    n_yStart = k
                    'Debug.Print n_yStart
                    Exit For
                Else
                    If k = n_yEnd Then
                        MsgBox "problem with " & tb_Name(i) & " the program will stop"
                        Exit Sub
                    Else
                    End If
                End If
            Next k
 
            ReDim tb_ToGGC(n_xEnd - 1, n_yEnd - n_yStart) 'must reverse col-row for redim preserve!!!!!!!!!!!
            For k = 0 To UBound(tb_ToGGC, 2)
                For m = 0 To UBound(tb_ToGGC, 1)
                    tb_ToGGC(m, k) = sh_ToTr.Cells(n_yStart + k, 1 + m).Value
                Next m
            Next k
 
            tb_RsltGGC = GetConsoCol(tb_iCol, tb_str1, tb_str2, tb_str3, tb_ToGGC, tb_Name(i))
            If bo_Stop = True Then
                Exit Sub
            Else
            End If
 
            ReDim Preserve tb_TotConso(n_Col, n_DimUpdate + UBound(tb_RsltGGC, 2) + 1)
            For k = 0 To n_Col
                For m = n_DimUpdate + 1 To n_DimUpdate + UBound(tb_RsltGGC, 2) + 1
                    tb_TotConso(k, m) = tb_RsltGGC(m - n_DimUpdate - 1, k - n_DimUpdate - 1)
                Next m
            Next k
            n_DimUpdate = UBound(tb_TotConso, 2)
 
        Next j
 
        '--- Fermeture connexion ---
        cn_X.Close
        Set cn_X = Nothing
 
    Next i
 
    sh_Conso.Range(sh_Conso.Cells(2, 1), sh_Conso.Cells(UBound(tb_TotConso, 2) + 2, UBound(tb_TotConso, 1) + 1)) = Application.Transpose(tb_TotConso)
 
End Sub
Public Function FirstRow(tb_i() As Byte, tb_x() As String, n_x As Long) As Boolean
Dim i As Long
 
    FirstRow = False
 
    For i = 0 To UBound(tb_i)
        If sh_ToTr.Cells(n_x, tb_i(i)) = tb_x(i) Then
            FirstRow = True
            Exit For
        Else
        End If
    Next i
 
End Function
Public Function GetConsoCol(tb_i() As Byte, tb_x1() As String, tb_x2() As String, tb_x3() As String, tb_xy() As Variant, str_filename As String) As Variant()
Dim i As Long, j As Long, k As Long
Dim bo_check As Boolean
Dim tb_ToGetRslt() As Variant
 
    ReDim tb_ToGetRslt(UBound(tb_i), UBound(tb_xy, 2) - 1) 'we put -1 for dim 2 because we don't want the headers
    Debug.Print UBound(tb_xy, 1) & "/" & UBound(tb_xy, 2)
 
    For i = 0 To UBound(tb_ToGetRslt, 1)
        bo_check = False
        For j = 0 To UBound(tb_xy, 1)
            If StrConv(tb_xy(j, 0), vbLowerCase) Like "*" & StrConv(tb_x1(i), vbLowerCase) & "*" Then
                For k = 1 To UBound(tb_xy, 2) 'we need here from 1 so we don't take the headers
                    tb_ToGetRslt(i, k - 1) = tb_xy(j, k)
                Next k
                bo_check = True
                Exit For
            Else
            End If
        Next j
        If bo_check = False Then
            For j = 0 To UBound(tb_xy, 1)
                If StrConv(tb_xy(j, 0), vbLowerCase) Like "*" & StrConv(tb_x2(i), vbLowerCase) & "*" Then
                    For k = 1 To UBound(tb_xy, 2) 'we need here from 1 so we don't take the headers
                        tb_ToGetRslt(i, k - 1) = tb_xy(j, k)
                    Next k
                    bo_check = True
                    Exit For
                Else
                End If
            Next j
        Else
        End If
        If bo_check = False Then
            For j = 0 To UBound(tb_xy, 1)
                If StrConv(tb_xy(j, 0), vbLowerCase) Like "*" & StrConv(tb_x3(i), vbLowerCase) & "*" Then
                    For k = 1 To UBound(tb_xy, 2) 'we need here from 1 so we don't take the headers
                        tb_ToGetRslt(i, k - 1) = tb_xy(j, k)
                    Next k
                    bo_check = True
                    Exit For
                Else
                End If
            Next j
        Else
        End If
        If bo_check = False Then
            bo_Stop = True
            MsgBox "problem with " & tb_x1(i) & " in " & str_filename & " the program will stop"
        Else
        End If
    Next i
 
    GetConsoCol = tb_ToGetRslt
 
End Function

**vanhoa** · 30/03/2017, 10h14

Du coup j'ai trouve moi meme la solution, je la donne, ca pourra peut etre servir a quelqu'un.

Dans la partie ou je creer la connexion:

Code :

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

1
2
3
4
5
6
With cn_X
    .Provider = "Microsoft.Jet.OLEDB.4.0"
    .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
     & str_toRead & ";Extended Properties=""Excel 12.0;HDR=NO;"""
    .Open
End With

Quand j'utilise mon code SQL: "SELECT * FROM [nom du worksheet]" cela va recuperer seulement le contenu, SANS les entetes.
HDR signifie "Header", YES signifie que le worksheet contient des entetes, NO le contraire.
Donc une astuce pour garder les entetes, on peut mettre "HDR=NO" (comme s'il n'y avait pas d'entetes) ce qui signifie que le code SQL va recuperer tout le contenu (y compris les entetes). Mais malheureusement cela ne recupere pas la premiere ligne de maniere exhaustive. Je pense que cela doit venir de la difference sur certains criteres entre le format de l'entete et celui de ses donnees .... enfin je pense.

Donc je vais le faire en 2 etapes.

Dans un premier temps je precise qu'il y a des entetes, donc je change le NO en YES, et je recupere les entetes separement avec Fields:

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
'-------------------------------------------------- recupe data ------------------------------------------------
     Debug.Print tb_strTab(j)
     texte_SQL = "SELECT * FROM [" & tb_strTab(j) & "]"
     Set Rst = New ADODB.Recordset 'we need the set as new as we put at the end cn_x=nothing, so when the i change in the loop, Rst is nothing so we have to create again
     Rst.Open texte_SQL, cn_X 'it works also if we don't code the line
     Set Rst = cn_X.Execute(texte_SQL)
     For k = 0 To Rst.Fields.Count - 1
         sh_ToTr.Cells(1, k + 1) = Rst.Fields(k).Name
     Next k
 
     sh_ToTr.Cells(2, 1).CopyFromRecordset Rst
 
'-------------------------------------------------- fin recupe data ------------------------------------------------

Et ca marche :-)

Lecture classeur ferme - probleme avec entetes

Macros et VBA Excel

Discussions similaires

Partager

Partager