XL 2013 Copier des données de plusieurs classeurs

[Lone-wolf]

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.

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 Sub

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.

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

 

[job75]

Bonjour Lone-wolf,

Juste pour te saluer et te dire qu'on est content de te retrouver sur XLD

A+

 

[Lone-wolf]

Bonjour Lone-wolf,

Juste pour te saluer et te dire qu'on est content de te retrouver sur XLD

A+

Bonsoir job75.

Merci beaucoup, plaisir de te relire.