Re:ADO Lecture Feuille Classeur Précise (Index 2)
Bonsoir Sylvie, Thierry, Michel
En fait, comme Sylvie indique que les feuilles-source s'appelle toujours 'calculs', il n'y a pas besoin d'utiliser ADOX.
Ci dessous une proposition de macro (faire attention aux antislash) non terminée car je dois m'absenter, excusez moi!. Il reste la restitution du tableau intermédiaire à faire et regarder l'histoire des étiquettes (ligne 28)
Mais comme on a pas pour l'instant d'info sur les 90 classeurs, il faudra voir si on restitue le tablo à chaque fichier ou globalement à la fin, ce qui me paraît plus rapide
Je terminerai tout cà si personne n'aura complété et amélioré
Bonne soirée
Michel
'Option Explicit
Const onglet As String = 'calculs'
Const zone As String = 'R18:U29' 'Une ligne enplus au dessus pour fausse ligne d'étiquette; voir avec HDR dans connection?
Function FichOuvert(F As String) As Boolean
'Auteur: Didier_mdf sur forum
www.Excel-downloads.com (merci)
Dim Wk As Workbook
On Error Resume Next
Set Wk = Workbooks(F) '(Merci à Ti pour cette astuce)
On Error GoTo 0
FichOuvert = Not Wk Is Nothing
End Function
Sub recup_zone()
Dim source As ADODB.Connection
Dim rqt As ADODB.Recordset
Dim chemin As String, classxls As String, fichier As String, texte_sql As String
Dim tablo()
Dim cptr As Long, lig As Byte
'initialisation provisoire
chemin = ThisWorkbook.Path
classxls = 'sylvie.xls'
fichier = chemin & '\\' & classxls
'teste si le classeur source est fermé
'If FichOuvert(fichier) = True Then
'MsgBox 'Pour que l'opération demandée soit effectuée,' & vbCr & _
''Le classeur ' & classxls & ' ne doit pas être ouvert. ', vbCritical
'Exit Sub
'End If
'active la connection
Set source = New ADODB.Connection
source.Open 'Provider = Microsoft.Jet.OLEDB.4.0;' & _
'data source=' & fichier & ';' & _
'extended properties=''Excel 8.0;'''
Set rqt = New Recordset
Set rqt = source.Execute('SELECT * from `' & onglet & '$' & zone & '`')
cptr = 1
ReDim tablo(cptr, 4)
rqt.MoveFirst
Do While Not rqt.EOF
If rqt.Fields(1) = Null Then
For col = 0 To 3
tablo(cptr - 1, col) = rqt.Fields(col)
Next col
End If
cptr = cptr + 1
ReDim tablo(cptr, 4)
rqt.MoveNext
Loop
' A fAIRE: rRESTITUTION TABLO DANS FEUILLe
Set rqt = Nothing
Set source = Nothing
End Sub
Je n'avais pas vu les 2 derniers échanges, excusez moi