Copier les données d'un classeur fermé vers un autre classeur ouvert en VBA ?

Question

Je sais que cette question a probablement déjà été posée, mais je me demandais s'il était possible de copier des données d'un autre classeur "fermé" vers mon classeur ouvert. J'ai essayé de faire des recherches et tout me dit que ce n'est pas possible... Je sais que c'est une question un peu ouverte.

Answer 1

Ah, ça me ramène quelques années en arrière. Je crois que cela a été fait par Ron il y a des années (expliqué sur une autre plateforme). Mais il y a deux façons de le faire. Une méthode que j'ai oubliée et qui récupère les cellules une par une et l'autre est la méthode ADO postée ci-dessous. Il y a d'abord deux exemples de sous-systèmes (une méthode pour amener les en-têtes et l'autre pour ne pas le faire), puis le sous-système ADO principal.

Option Explicit

Sub GetData_ExampleV1()
' It will copy the Header row also (the last two arguments are True)
' Change the last argument to False if you not want to copy the header row
    GetData ThisWorkbook.Path & "\test.xlsx", "Sheet1", _
            "A1:C5", Sheets("Sheet1").Range("A1"), True, True
End Sub

Sub GetData_ExampleC2()
' It will not copy the Header row (the last two arguments are True, False)
' Change the last argument to True if you also want to copy the header row
    GetData ThisWorkbook.Path & "\test.xlsx", "Sheet1", _
            "A1:C5", Sheets("Sheet1").Range("A1"), True, False
End Sub

C'est l'ADO (fonction) que vous appelez pour le faire.

Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
                   SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
    Dim rsCon As Object
    Dim rsData As Object
    Dim szConnect As String
    Dim szSQL As String
    Dim lCount As Long

    ' Create the connection string.
    If Header = False Then
        If Val(Application.Version) < 12 Then
            szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 8.0;HDR=No"";"
        Else
            szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=No"";"
        End If
    Else
        If Val(Application.Version) < 12 Then
            szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 8.0;HDR=Yes"";"
        Else
            szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=Yes"";"
        End If
    End If

    If SourceSheet = "" Then
        ' workbook level name
        szSQL = "SELECT * FROM " & SourceRange$ & ";"
    Else
        ' worksheet level name or range
        szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
    End If

    On Error GoTo SomethingWrong

    Set rsCon = CreateObject("ADODB.Connection")
    Set rsData = CreateObject("ADODB.Recordset")

    rsCon.Open szConnect
    rsData.Open szSQL, rsCon, 0, 1, 1

    ' Check to make sure we received data and copy the data
    If Not rsData.EOF Then

        If Header = False Then
            TargetRange.Cells(1, 1).CopyFromRecordset rsData
        Else
            'Add the header cell in each column if the last argument is True
            If UseHeaderRow Then
                For lCount = 0 To rsData.Fields.Count - 1
                    TargetRange.Cells(1, 1 + lCount).Value = _
                    rsData.Fields(lCount).Name
                Next lCount
                TargetRange.Cells(2, 1).CopyFromRecordset rsData
            Else
                TargetRange.Cells(1, 1).CopyFromRecordset rsData
            End If
        End If

    Else
        MsgBox "No records returned from : " & SourceFile, vbCritical
    End If

    ' Clean up our Recordset object.
    rsData.Close
    Set rsData = Nothing
    rsCon.Close
    Set rsCon = Nothing
    Exit Sub

SomethingWrong:
    MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
           vbExclamation, "Error"
    On Error GoTo 0

End Sub