Lone-wolf
XLDnaute Barbatruc
Bonsoir à toutes et à tous. J'éspère que vous allez tous bien, malgré cette char...... .
J'ai un souci avec ADODB pour la copie de données de 6 classeurs (pour l'instant). Avant celà, j'ai utilisé Workbook.Open. La macro fonctionne bien, mais le problème c'est que, malgré ScreenUpdating = False, on vois l'ouverture des classeurs.
Voici le code ADO que j'utilise.
Note: ces copies doivent-être faites à la suite et il faut utiliser Classeur1.
Comme les lignes sont variables, avec ADO, je ne sais pas comment il faut faire.
Pour ceux qui seraient intêressés, voici le code avec Workbook.Open.
J'ai un souci avec ADODB pour la copie de données de 6 classeurs (pour l'instant). Avant celà, j'ai utilisé Workbook.Open. La macro fonctionne bien, mais le problème c'est que, malgré ScreenUpdating = False, on vois l'ouverture des classeurs.
Voici le code ADO que j'utilise.
VB:
Option Explicit
Sub RequeteClasseursFermes()
Dim Fichier As String, Chemin As String
Dim NomFeuille As String, Requete As String
Dim Rec As Object, Cnn As Object, Lig As Integer
Chemin = ThisWorkbook.Path & "\Representants\"
Fichier = Dir(Chemin & "*.xlsx")
NomFeuille = "Chiffre_Affaire"
Set Cnn = CreateObject("ADODB.Connection")
Cnn.Provider = "MSDASQL"
Cnn.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & _
"DBQ=" & Fichier & "; ReadOnly=False;"
Do While Fichier <> ""
Requete = "SELECT * FROM [" & NomFeuille & "]"
Set Rec = CreateObject("ADODB.Recordset")
Set Rec = Cnn.Execute(Requete)
Rec.Open Requete, Cnn, 3
Lig = Range("a" & Rows.Count).End(xlUp).Row + 1
Range("a" & Lig).CopyFromRecordset Rec
Fichier = Dir
Loop
Cnn.Close
Set Cnn = Nothing
End SubNote: ces copies doivent-être faites à la suite et il faut utiliser Classeur1.
Comme les lignes sont variables, avec ADO, je ne sais pas comment il faut faire.
Pour ceux qui seraient intêressés, voici le code avec Workbook.Open.
Code:
Option Explicit
Dim ShCa As Worksheet, fichiers As String, chemin As String
Dim lig As Integer, Lgn As Integer, col As Integer, i As Integer
Dim derlig As Integer, k As Integer, Tbl(), Bd, tablo
Sub Consolidation_Donnees()
Application.ScreenUpdating = False
chemin = ThisWorkbook.Path & "\Representants\"
fichiers = Dir(chemin & "*.xls")
Set ShCa = ThisWorkbook.Sheets("Rapport_CA")
With ShCa
.Range("j3, k3").ClearContents
lig = .Range("a" & Rows.Count).End(xlUp).Row
.Range("a2:g" & lig).ClearContents
End With
col = 0: k = 0: Lgn = 0
Do While fichiers <> ""
Workbooks.Open chemin & fichiers
With ActiveWorkbook
derlig = .Sheets("Chiffre_Affaire").Range("a" & Rows.Count).End(xlUp).Row
Bd = .Sheets("Chiffre_Affaire").Range("a2:g" & derlig).Value
End With
For i = LBound(Bd) To UBound(Bd)
If Bd(i, 1) <> vbNullString Then
Lgn = Lgn + 1: col = col + 1: ReDim Preserve Tbl(1 To UBound(Bd, 2), 1 To col)
For k = 1 To UBound(Bd, 2): Tbl(k, col) = Bd(i, k): Next k
End If
Next i
If col > 0 Then
With ShCa
lig = .Range("a" & Rows.Count).End(xlUp).Row + 1
.Range("a" & lig).Resize(Lgn, UBound(Bd, 2)) = Application.Transpose(Tbl)
col = 0: k = 0: Lgn = 0
End With
End If
ActiveWorkbook.Close True
fichiers = Dir
Loop
tablo = [{"Representant", "Client", "Date Com.", "Date Fact.", "DatePaiem.", "Montant HT", "Montant HTTC"}] 'Array
For i = LBound(tablo) To UBound(tablo)
ShCa.Cells(1, i) = tablo(i)
Next i
With ShCa
.Range("j3") = "Chiffre d'affaire: "
.Range("k3") = Application.Sum(.Range(.Cells(2, 7), .Cells(.Rows.Count, 7).End(3)))
.Range("a2:g900000").Sort .Range("a2"), xlAscending
.Range("A:G").Columns.AutoFit
End With
End Sub
Dernière édition:
