Forum - Excel07 Πως κατεβάζω σελίδα;

Forum (https://www.ms-office.gr/forum/)

- Excel - Ερωτήσεις / Απαντήσεις (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/)

- - [Excel07] Πως κατεβάζω σελίδα; (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/2432-pos-katebazo-selida.html)

Πως κατεβάζω σελίδα;

Καλημέρα και Χρόνια Πολλά σε όλους,
Θα ηθελα να με βοηθησετε να μπορεσω να κανω το εξης:
Δεν μπορω να κατεβασω απο ενα url τον κεντρικο πινακα που βλεπω μιας και στην εισαγωγη που κανω απο εξωτερικα δεδομενα παιρνω το μηνυμα οτι το ερωτημα στο web δεν επεστρεψε δεδομενα..
Ειμαι νεος και δεν μου επιτρεπει ακομα το φορουμ να βαλω το url Αν υπαρχει καποιο πρωτο βημα καθοδηγησης?

Καλησπέρα και καλώς όρισες.

Γράψε μας την διεύθυνση χωρίς να επιλέξεις εισαγωγή URL και αφαιρώντας το http://

1x2.7m.hk/result_en.shtml?dt=2012-07-09&cid=254

Απο αυτη την σελιδα θελω τον κεντρικο πινακα και αν ειναι δυνατον να κατεβαζω πολλες ημερομηνιες παλιες

Καλημέρα και καλώς όρισες.

Ορισμένες ιστοσελίδες για δικούς τους λόγους (τεχνικούς ή μη) δεν μπορούν να περιέχουν δεδομένα
που είναι προσβάσιμα από προγράμματα όπως η Excel.

Εφόσον όμως τα δεδομένα αυτά καταλήγουν στον υπολογιστή, υπάρχει πάντα κάποιος τρόπος (αναλόγως την ιστοσελίδα) που επιτρέπει την εισαγωγή τους στην Excel.

To παράδειγμα στο συνημμένο περιέχει κώδικα VBA που ανοίγει σε μη ορατό Internet Explorer την επιθυμητή ιστοσελίδα, αντιγράφει τα δεδομένα σε αρχείο *.html που δημιουργεί στον ίδιο φάκελο και εισάγει τα δεδομένα αυτά με την κλασσική μέθοδο εισαγωγής δεδομένων από το Web.

Θα πρέπει να ενεργοποιηθούν οι μακροεντολές για να λειτουργήσει.

Χρειάζεται να γνωρίζει κανείς τουλάχιστον τα κλασικά προγραμματισμού σε Excel, HTML, VBA αλλά και του αντικειμένου Internet Explorer για να προσαρμόσει το παράδειγμα στα μέτρα του.

Καλή συνέχεια!

Τάσος

Σ ευχαριστω για το χρονο που διεθεσες να με βοηθησεις ωστόσο όσες προσπαθειες και αν εκανα το μηνυμα που παιρνω ειναι να "ελενξω την συνδεση του ιντερνετ" και ετσι δεν μπορεσα να δω αν κατεβαζει και πως...

Καλησπέρα!

Το πρόβλημα δεν βρίσκεται στο αρχείο αλλά στους Dns του συγκεκριμένου Server.

Άλλαξα το συνημμένο με ένα νέο. Η μόνη τεχνική διαφορά που βελτιώνει λίγο την κατάσταση είναι ότι προστέθηκαν αναφορές στο έργο VBA προκειμένου να βελτιωθεί η απόκριση αλλά και η απόδοση του παραδείγματος.

Μπορείς να δοκιμάσεις το νέο συνημμένο. Σε μένα λειτουργεί κανονικά αλλά όπως είπα δεν μπορούμε να επηρεάσουμε βασικούς παράγοντες όπως είναι η ταχύτητα και η απόκριση του Server.

Τάσος

Ωραια χτυπαει τωρα και η ταχυτητα του ειναι παρα πολυ καλη ...Μονο απαραιτητο είναι στο url που βαζουμε στον κωδικα ειναι να υπαρχει και το cid=254 για να παιρνει απο συγκεκριμενη εταιρια και οχι τον μεσο ορο που ειναι απαραιτητο για να γινει η δουλεια μας........

1x2.7m.hk/result_en.shtml?dt=2012-07-09&cid=254

Στο συγκεκριμένο αρχείο κάνε κλικ σε ένα κελί και πάτησε ALT + F11
Στο παράθυρο που θα εμφανιστεί, αντικατέστησε όλο τον κώδικα που υπάρχει στη λειτουργική μονάδα "Module1" με τον παρακάτω:

Κώδικας:

Option Explicit
 

Sub GetWebData()

    Dim ie As InternetExplorer

    Dim oBody As HTMLBody

    Dim oTable As HTMLTable

    Dim TableCol As IHTMLElementCollection

    Dim strFilePath As String

    Dim fso As Scripting.FileSystemObject

    Dim oStream As Scripting.TextStream

    Dim strDate As String

    Dim ieResponseTimeout As Date

    Dim ProgRange As Range

    Dim TablehasData As Boolean

    Dim tblCount As Integer

    Set ProgRange = Range("progress")

    If IsDate(ShWebImport.Range("C1").Value) Then

        strDate = Format(ShWebImport.Range("C1").Value, "yyyy-MM-dd")

    Else

        ShWebImport.Activate

        Range("C1").Select

        ActiveWindow.ScrollRow = 1

        ProgRange = "Συμπλήρωσε ημερομηνία στο παραπάνω κελί"

        Exit Sub

    End If

    strFilePath = ThisWorkbook.Path & "\htm.html"

    Set fso = CreateObject("Scripting.FileSystemObject")

    Set ie = CreateObject("InternetExplorer.Application")

    ie.RegisterAsBrowser = True

    '     ie.Visible = True

    ieResponseTimeout = Now + TimeSerial(0, 0, 20)

    On Error GoTo Exithere
 

    ProgRange = "Εισαγωγή δεδομένων από το web..."

    ie.Navigate2 "http://1x2.7m.hk/result_en.shtml?dt=" & strDate & "&cid=254"

     While ie.readyState <> READYSTATE_COMPLETE Or ie.Busy

        DoEvents

        If Now > ieResponseTimeout Then

            ProgRange = "Δεν είναι δυνατή η σύνδεση με την ιστοσελίδα."

            GoTo Exithere

        End If

    Wend

    If ie.document.URL Like "res://*" Then GoTo Exithere

    Set oBody = ie.document.body

    Set TableCol = oBody.getElementsByTagName("table")

    tblCount = TableCol.Length

    If tblCount Then

        ProgRange = "Επεξεργάζομαι δεδομένα..."

        For Each oTable In TableCol

            DoEvents

            If oTable.className = "t1" And oTable.Width = "598" Then

                ProgRange = "Δημιουργία τοπικού αρχείου *.html..."

                Set oStream = fso.CreateTextFile(strFilePath, True, True)

                oStream.write "<table>" & oTable.innerHTML & "</table>"

                oStream.Close

                TablehasData = True

                Exit For

            End If

        Next
 

    End If

Exithere:

    On Error Resume Next

    If Not ie Is Nothing Then

        ie.ExecWB OLECMDID_CLOSE, OLECMDEXECOPT_DONTPROMPTUSER, 0, 0

        Set ie = Nothing

        If Err <> 0 Then

            ProgRange = "Σφάλμα " & Err & " : " & Err.Description

            Exit Sub

        End If

    End If

    If TablehasData Then

        If ShWebImport.QueryTables.Count Then

            With ShWebImport.QueryTables(1)

                .Connection = "URL;file:///" & Replace(strFilePath, "\", "/")

                .Refresh BackgroundQuery:=False

                ProgRange = "Έγινε!"

            End With

        End If

    Else

        If tblCount Then

            ProgRange = "Δεν υπάρχουν δεδομένα για αυτή την ημερομηνία."

        Else

            ProgRange = "Δεν είναι δυνατη ησύνδεση με την ιστοσελίδα."

        End If

    End If

    If Err <> 0 Then

        ProgRange = "Error " & Err & " : " & Err.Description

    End If

End Sub

Αν δεν μπορείς να δεις τον αρχικό κώδικα, κάνε διπλό κλικ στη λειτουργική μονάδα "Module1" για να τον εμφανίσεις.

Καλή συνέχεια!

Τάσος