Url Excel Dosyasını Excel İçine İndirmek

[Ömer2134]

Arkadaşlar merhaba

Yapmak istediğim linkte bulunan excel dosyasını excel içine indirmek. Yanı ana excel dosyamda bir button olacak. Butona bastığımda urldeki excel dosyasının içindeki veriler ana excel dosyama gelecek. Aşağıdaki gibi bir kod buldum ama çalıştıramadım. Link aşağıdaki gibidir.

https://file-examples-com.github.io/uploads/2017/02/file_example_XLS_10.xls

Option Explicit

Sub ImportHistoricalDataSheet()

    Const SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS = 13056
    Const adSaveCreateOverWrite = 2

    Dim aBody, sPath

    ' Download Historical Data xls file via XHR
    With CreateObject("MSXML2.XMLHTTP")
    'With CreateObject("MSXML2.ServerXMLHTTP")
        '.SetOption 2, SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS
        .Open "GET", "https://file-examples-com.github.io/uploads/2017/02/file_example_XLS_10.xls"
        .Send
        ' Get binary response content
        aBody = .responseBody
        ' Retrieve filename from headers and concatenate full path
        sPath = ThisWorkbook.Path & "\" & Replace(Split(Split(.GetAllResponseHeaders, "filename=", 2)(1), vbCrLf, 2)(0), "/", "-")
    End With
    ' Save binary content to the xls file
    With CreateObject("ADODB.Stream")
        .Type = 1
        .Open
        .Write aBody
        .SaveToFile sPath, adSaveCreateOverWrite
        .Close
    End With
    ' Open saved workbook
    With Workbooks.Open(sPath, , True)
        ' Get 1st worksheet values to array
        aBody = .Worksheets(1).UsedRange.Value
        .Saved = True
        .Close
    End With
    ' Delete saved workbook file
    CreateObject("Scripting.FileSystemObject").DeleteFile sPath, True
    ' Insert array to target worksheet
    ThisWorkbook.Sheets("Sheet1").Cells(1, 1).Resize(UBound(aBody, 1), UBound(aBody, 2)).Value = aBody

End Sub

Teşekkürler.

 

[Ömer]

Merhaba

Deneyiniz.
Verileri alacağınız çalışma sayfasının adını "Sayfa1" olarak yazdım, ( End Sub satırından önce ) siz kendinize göre değiştirirsiniz.
Birde sPath tanımındaki dosya adını değiştirdim. Bu dosya zaten sonradan siliniyor.
Aşağıdaki gibi denedim bende çalıştı.

Sub ImportHistoricalDataSheet()

    Const SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS = 13056
    Const adSaveCreateOverWrite = 2

    Dim aBody, sPath

    ' Download Historical Data xls file via XHR
    With CreateObject("MSXML2.XMLHTTP")
    'With CreateObject("MSXML2.ServerXMLHTTP")
        '.SetOption 2, SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS
        .Open "GET", "https://file-examples-com.github.io/uploads/2017/02/file_example_XLS_10.xls"
        .Send
        ' Get binary response content
        aBody = .responseBody
        ' Retrieve filename from headers and concatenate full path
          sPath = ThisWorkbook.Path & "\" & "file_example_XLS_10.xls" 'Replace(Split(Split(.GetAllResponseHeaders, "filename=", 2)(1), vbCrLf, 2)(0), "/", "-")
    End With
    ' Save binary content to the xls file
    With CreateObject("ADODB.Stream")
        .Type = 1
        .Open
        .Write aBody
        .SaveToFile sPath, adSaveCreateOverWrite
        .Close
    End With
    ' Open saved workbook
    With Workbooks.Open(sPath, , True)
        ' Get 1st worksheet values to array
        aBody = .Worksheets(1).UsedRange.Value
        .Saved = True
        .Close
    End With
    ' Delete saved workbook file
    CreateObject("Scripting.FileSystemObject").DeleteFile sPath, True
    ' Insert array to target worksheet
    ThisWorkbook.Sheets("Sayfa1").Cells(1, 1).Resize(UBound(aBody, 1), UBound(aBody, 2)).Value = aBody

End Sub

 

[Ömer2134]

Teşekkürler Ömer bey çalıştı.