Importa da sito

[apocrimata75]

Ho trovato un altro sito che preferisce oscurare i suoi dati durante l'importazione su foglio excel.

Ho provato con le queryweb e "restituisce" solo alcuni dati che invece a video risultano presenti. Memore di altro post ho provato con la macro

Codice: Seleziona tutto

Sub pipp()

myUrl = "http://www.progsport.com/icehockey/"
Set IE = CreateObject("InternetExplorer.Application")
   
With IE
    .navigate myUrl
    .Visible = True
    Do While .Busy: DoEvents: Loop    'Attesa not busy
    Do While .readyState <> 4: DoEvents: Loop 'Attesa documento
End With
'
myStart = Timer  'attesa addizionale
Do
    DoEvents
    If Timer > myStart + 1 Or Timer < myStart Then Exit Do
Loop
'Leggi le tabelle, su un nuovo foglio
Sheets("Foglio4").Select     '<<< Vedi testo

Set myColl = IE.document.getElementsByTagName("TABLE")
If myColl.Length < 5 Then
    MsgBox ("Numero anomalo di tabelle, abortito")
    GoTo IEQuit
End If
With myColl(4)
    For Each trtr In .Rows
        For Each tdtd In trtr.Cells
            Cells(i + 1, J + 1) = tdtd.innerText
            Cells(i + 1, 1).Select
            J = J + 1
        Next tdtd
        i = i + 1: J = 0
    Next trtr
i = i + 2
'Next myItm
End With

Set myColl = IE.document.getElementsByTagName("TABLE")
If myColl.Length < 5 Then
    MsgBox ("Numero anomalo di tabelle, abortito")
    GoTo IEQuit
End If
With myColl(5)
    For Each trtr In .Rows
        For Each tdtd In trtr.Cells
            Cells(i + 1, J + 1) = tdtd.innerText
            Cells(i + 1, 1).Select
            J = J + 1
        Next tdtd
        i = i + 1: J = 0
    Next trtr
i = i + 2
'Next myItm
End With

Set myColl = IE.document.getElementsByTagName("TABLE")
If myColl.Length < 5 Then
    MsgBox ("Numero anomalo di tabelle, abortito")
    GoTo IEQuit
End If
With myColl(10)
    For Each trtr In .Rows
        For Each tdtd In trtr.Cells
            Cells(i + 1, J + 1) = tdtd.innerText
            Cells(i + 1, 1).Select
            J = J + 1
        Next tdtd
        i = i + 1: J = 0
    Next trtr
i = i + 2
'Next myItm
End With
'Next II
SendKeys "{F5}", True
        SendKeys "{ENTER}", True
IEQuit:
'Chiusura IE
IE.Quit
Set IE = Nothing

SendKeys "{F5}", True
        SendKeys "{ENTER}", True

   
   End Sub

ma non importa niente.

Ho provato con

Codice: Seleziona tutto

Sub Macro4()

Sheets("Foglio4").Select


myUrl = "http://www.progsport.com/icehockey/"
Set IE = CreateObject("InternetExplorer.Application")
   
With IE
    .navigate myUrl
    .Visible = True
    Do While .Busy: DoEvents: Loop    'Attesa not busy
    Do While .readyState <> 4: DoEvents: Loop 'Attesa documento
End With
'
myStart = Timer  'attesa addizionale
Do
    DoEvents
    If Timer > myStart + 1 Or Timer < myStart Then Exit Do
Loop
'Leggi le tabelle, su un nuovo foglio
Sheets("Foglio4").Select     '<<< Vedi testo

Set myColl = IE.document.getElementsByTagName("TABLE")
If myColl.Length < 5 Then
    MsgBox ("Numero anomalo di tabelle, abortito")
    GoTo IEQuit
End If
With myColl(4)
    For Each trtr In .Rows
        For Each tdtd In trtr.Cells
            Cells(i + 1, J + 1) = tdtd.innerText
            Cells(i + 1, 1).Select
            J = J + 1
        Next tdtd
        i = i + 1: J = 0
    Next trtr
i = i + 2
'Next myItm
End With

Set myColl = IE.document.getElementsByTagName("TABLE")
If myColl.Length < 5 Then
    MsgBox ("Numero anomalo di tabelle, abortito")
    GoTo IEQuit
End If
With myColl(5)
    For Each trtr In .Rows
        For Each tdtd In trtr.Cells
            Cells(i + 1, J + 1) = tdtd.innerText
            Cells(i + 1, 1).Select
            J = J + 1
        Next tdtd
        i = i + 1: J = 0
    Next trtr
i = i + 2
'Next myItm
End With

Set myColl = IE.document.getElementsByTagName("TABLE")
If myColl.Length < 5 Then
    MsgBox ("Numero anomalo di tabelle, abortito")
    GoTo IEQuit
End If
With myColl(10)
    For Each trtr In .Rows
        For Each tdtd In trtr.Cells
            Cells(i + 1, J + 1) = tdtd.innerText
            Cells(i + 1, 1).Select
            J = J + 1
        Next tdtd
        i = i + 1: J = 0
    Next trtr
i = i + 2
'Next myItm
End With
'Next II
SendKeys "{F5}", True
        SendKeys "{ENTER}", True
IEQuit:
'Chiusura IE
IE.Quit
Set IE = Nothing

SendKeys "{F5}", True
        SendKeys "{ENTER}", True

   End Sub


ma non importa i valori nascosti.


Ci sono altre soluzioni?

Grazie anticipatamente.

[scossa]

Ho trovato un altro sito che preferisce oscurare i suoi dati durante l'importazione su foglio excel.

Ho provato con le queryweb e "restituisce" solo alcuni dati che invece a video risultano presenti.

Purtroppo i "furbetti" di quel sito hanno sostituito le singole cifre che compongono i valori delle "outcome prediction (%)" con delle GIF.
Quindi l'unico modo è di convertire il nome della gif nella relativo cifra.

Ho modificato il codice per fare questo.

Condizioni: nelle righe 4 e 5 del "Foglio4" contengono le intestazione che scriverai tu:

Codice: Seleziona tutto

ΜATCHES       OUTCOME PREDICTION(%)               AVERAGE ODDS      UNDER/OVER      FINAL
HOME team  -   AWAY team   1    X    2   TIPS      1    X    2    5.5-    5.5+      RESULT

Questo il codice:

Codice: Seleziona tutto

Sub pippo()
  Dim myUrl As String
  Dim ie As Object
  Dim myColl As Object
  Dim mySubColl As Object
  Dim trtr As Object
  Dim tdtd As Object
  Dim imgimg As Object
  Dim prepre As Object
  Dim myStart As Single
  Dim nRoff As Long
  Dim nCoff As Long
  Dim sNum As String
  Dim rngTo As Range
  Dim nTd As Integer
  Dim bImg As Boolean
 
  Set rngTo = ThisWorkbook.Worksheets("Foglio4").Range("A6")
  rngTo.Resize(Cells(Rows.Count, 1).End(xlUp).Row, 12).ClearContents
  myUrl = "http://www.progsport.com/icehockey/"
  Set ie = CreateObject("InternetExplorer.Application")
     
  With ie
      .navigate myUrl
      .Visible = True
      Do While .Busy: DoEvents: Loop    'Attesa not busy
      Do While .readyState <> 4: DoEvents: Loop 'Attesa documento
  End With
  '
  myStart = Timer  'attesa addizionale
  Do
      DoEvents
      If Timer > myStart + 1 Or Timer < myStart Then Exit Do
  Loop
  'Leggi le tabelle, su un nuovo foglio
  Sheets("Foglio1").Select     '<<< Vedi testo
 
  Set myColl = ie.document.getElementsByTagName("TABLE").Item(5)
  Set mySubColl = myColl.getElementsByTagName("TR")
  nRoff = 0
  nCoff = 0
  For Each trtr In mySubColl
    For Each imgimg In trtr.getElementsByTagName("IMG")
      If imgimg.classname Like "im" Then
        rngTo.Offset(nRoff, nCoff).Value = imgimg.parentelement.innertext
      End If
    Next
    If trtr.classname Like "f?" Then nRoff = nRoff + 1
  Next
  nRoff = 0
  nCoff = 1
  Set mySubColl = myColl.getElementsByTagName("PRE")
  For Each prepre In mySubColl
    rngTo.Offset(nRoff, nCoff) = Trim(prepre.innertext)
    nRoff = nRoff + 1
  Next
  Set mySubColl = myColl.getElementsByTagName("TR")
  bImg = True
  nRoff = 0
  nTd = 1
  nCoff = 2
      For Each tdtd In myColl.getElementsByTagName("TD")
       
        If tdtd.classname Like "po*" And bImg Then
          'nTd = nTd + 1
          sNum = ""
          For Each imgimg In tdtd.Children
            Select Case imgimg.nameprop
              Case "A2.gif"
                sNum = sNum & "1"
              Case "B2.gif"
                sNum = sNum & "9"
              Case "C2.gif"
                sNum = sNum & "3"
              Case "D2.gif"
                sNum = sNum & "6"
              Case "E2.gif"
                sNum = sNum & "0"
              Case "F2.gif"
                sNum = sNum & "8"
              Case "G2.gif"
                sNum = sNum & "7"
              Case "H2.gif"
                sNum = sNum & "2"
              Case "K2.gif"
                sNum = sNum & "4"
              Case "L2.gif"
                sNum = sNum & "5"
            End Select
          Next
          rngTo.Offset(nRoff, nCoff) = sNum
          nCoff = nCoff + 1
          nTd = nTd + 1
        ElseIf tdtd.classname Like "po*" And Not bImg Then
          rngTo.Offset(nRoff, nCoff) = tdtd.innertext
          nCoff = nCoff + 1
          nTd = nTd + 1
        ElseIf tdtd.classname Like "ao*" Then
          nTd = nTd + 1
          rngTo.Offset(nRoff, nCoff) = tdtd.innertext
          nCoff = nCoff + 1
          bImg = False
        ElseIf tdtd.classname Like "f?r" Then
          nTd = nTd + 1
          rngTo.Offset(nRoff, nCoff) = tdtd.innertext
        ElseIf tdtd.classname Like "FA?" Then
          Select Case True
            Case InStr(tdtd.outerhtml, "1B.gif") > 0
              rngTo.Offset(nRoff, nCoff) = "1"
            Case InStr(tdtd.outerhtml, "2B.gif") > 0
              rngTo.Offset(nRoff, nCoff) = "2"
            Case InStr(tdtd.outerhtml, "12.gif") > 0
              rngTo.Offset(nRoff, nCoff) = "12"
          End Select
          nTd = nTd + 1
          nCoff = nCoff + 1
          ' nCoff =
        End If
        If nTd >= 11 Then
          nRoff = nRoff + 1
          nCoff = 2
          nTd = 1
          bImg = True
        End If
      Next tdtd
 
IEQuit:
  'Chiusura IE
  ie.Quit
  Set ie = Nothing
  Set rngTo = Nothing
End Sub



Fai sapere, grazie.

[apocrimata75]

mitico, funziona perfettamente (c'era solo un refuso ma risolto subito).

Grazie mille.