leggere link da cella excel

[gioninos]

Salve modificando un po' una macro trovata sul web, sono riuscito a a relizzarne una che mi importa i dati di due link : http://www.betexplorer.com/soccer/england/premier-league/results/
http://www.oddsportal.com/soccer/england/premier-league/results/
ed esattamente per quest'ultimo le 8 pag che vengono a crearsi nell'arco di un intero campionato:
http://www.oddsportal.com/soccer/england/premier-league/results/#/page/2/
http://www.oddsportal.com/soccer/england/premier-league/results/#/page/3/
http://www.oddsportal.com/soccer/england/premier-league/results/#/page/4/
http://www.oddsportal.com/soccer/england/premier-league/results/#/page/5/
http://www.oddsportal.com/soccer/england/premier-league/results/#/page/6/
http://www.oddsportal.com/soccer/england/premier-league/results/#/page/7/
http://www.oddsportal.com/soccer/england/premier-league/results/#/page/8/
Infine i dati del link:
http://www.betexplorer.com/soccer/england/premier-league/fixtures/

Codice: Seleziona tutto

Sub ENGLANDPREMIER()
'
' ENGLANDPREMIER Macro
'
Dim mIE As Object
  Dim mTables, mTable
  Dim mRows, mRow
  Dim mCells, mCell
  Dim mRiga As Long, mColonna As Long
  Dim k As Integer

 
  Set mIE = CreateObject("InternetExplorer.Application")
  k = 0
  mRiga = 17
  With mIE
    .AddressBar = False
    .StatusBar = False
    .MenuBar = False
    .Toolbar = 0
    .Visible = False
    .navigate "http://www.betexplorer.com/soccer/england/premier-league/results/"

  End With
 
  While mIE.Busy
  Wend
  While mIE.document.readyState <> "complete"
  Wend
 
  Set mTables = mIE.document.all.tags("TABLE")
  For Each mTable In mTables
      Set mRows = mTable.Rows
      For Each mRow In mRows
        Set mCells = mRow.Cells
        If Cells(mRiga - 1, 1) = "" Or Cells(mRiga - 1, 1) = "No." Then
        mColonna = 1
        Else
        mColonna = 1
        End If
        If k = 1 Then mColonna = 1
        For Each mCell In mCells
       
          ActiveSheet.Cells(mRiga, mColonna) = mCell.innerText
          mColonna = mColonna + 1
        Next mCell
        mRiga = mRiga + 1
      Next mRow
      k = 1
  Next mTable
 
Azzera_Variabili:
  Set mCell = Nothing
  Set mCells = Nothing
  Set mRow = Nothing
  Set mRows = Nothing
  Set mTable = Nothing
  Set mTables = Nothing
  mIE.Quit
  Set mIE = Nothing
 
 
 
 

 
  Set mIE = CreateObject("InternetExplorer.Application")
  k = 0
  mRiga = 500
  With mIE
    .AddressBar = False
    .StatusBar = False
    .MenuBar = False
    .Toolbar = 0
    .Visible = False
    .navigate "http://www.oddsportal.com/soccer/england/premier-league/results/"

  End With
 
  While mIE.Busy
  Wend
  While mIE.document.readyState <> "complete"
  Wend
 
  Set mTables = mIE.document.all.tags("TABLE")
  For Each mTable In mTables
      Set mRows = mTable.Rows
      For Each mRow In mRows
        Set mCells = mRow.Cells
        If Cells(mRiga - 1, 1) = "" Or Cells(mRiga - 1, 1) = "No." Then
        mColonna = 1
        Else
        mColonna = 1
        End If
        If k = 1 Then mColonna = 1
        For Each mCell In mCells
       
          ActiveSheet.Cells(mRiga, mColonna) = mCell.innerText
          mColonna = mColonna + 1
        Next mCell
        mRiga = mRiga + 1
      Next mRow
      k = 1
  Next mTable
 

 
 Set mIE = CreateObject("InternetExplorer.Application")
  k = 0
  mRiga = 600
  With mIE
    .AddressBar = False
    .StatusBar = False
    .MenuBar = False
    .Toolbar = 0
    .Visible = False
    .navigate "http://www.oddsportal.com/soccer/england/premier-league/results/#/page/2/"

  End With
 
  While mIE.Busy
  Wend
  While mIE.document.readyState <> "complete"
  Wend
 
  Set mTables = mIE.document.all.tags("TABLE")
  For Each mTable In mTables
      Set mRows = mTable.Rows
      For Each mRow In mRows
        Set mCells = mRow.Cells
        If Cells(mRiga - 1, 1) = "" Or Cells(mRiga - 1, 1) = "No." Then
        mColonna = 1
        Else
        mColonna = 1
        End If
        If k = 1 Then mColonna = 1
        For Each mCell In mCells
       
          ActiveSheet.Cells(mRiga, mColonna) = mCell.innerText
          mColonna = mColonna + 1
        Next mCell
        mRiga = mRiga + 1
      Next mRow
      k = 1
  Next mTable
 
 
 
 
 
 
  Set mIE = CreateObject("InternetExplorer.Application")
  k = 0
  mRiga = 700
  With mIE
    .AddressBar = False
    .StatusBar = False
    .MenuBar = False
    .Toolbar = 0
    .Visible = False
    .navigate "http://www.oddsportal.com/soccer/england/premier-league/results/#/page/3/"

  End With
 
  While mIE.Busy
  Wend
  While mIE.document.readyState <> "complete"
  Wend
 
  Set mTables = mIE.document.all.tags("TABLE")
  For Each mTable In mTables
      Set mRows = mTable.Rows
      For Each mRow In mRows
        Set mCells = mRow.Cells
        If Cells(mRiga - 1, 1) = "" Or Cells(mRiga - 1, 1) = "No." Then
        mColonna = 1
        Else
        mColonna = 1
        End If
        If k = 1 Then mColonna = 1
        For Each mCell In mCells
       
          ActiveSheet.Cells(mRiga, mColonna) = mCell.innerText
          mColonna = mColonna + 1
        Next mCell
        mRiga = mRiga + 1
      Next mRow
      k = 1
  Next mTable
 
 
 
   Set mIE = CreateObject("InternetExplorer.Application")
  k = 0
  mRiga = 800
  With mIE
    .AddressBar = False
    .StatusBar = False
    .MenuBar = False
    .Toolbar = 0
    .Visible = False
    .navigate "http://www.oddsportal.com/soccer/england/premier-league/results/#/page/4/"

  End With
 
  While mIE.Busy
  Wend
  While mIE.document.readyState <> "complete"
  Wend
 
  Set mTables = mIE.document.all.tags("TABLE")
  For Each mTable In mTables
      Set mRows = mTable.Rows
      For Each mRow In mRows
        Set mCells = mRow.Cells
        If Cells(mRiga - 1, 1) = "" Or Cells(mRiga - 1, 1) = "No." Then
        mColonna = 1
        Else
        mColonna = 1
        End If
        If k = 1 Then mColonna = 1
        For Each mCell In mCells
       
          ActiveSheet.Cells(mRiga, mColonna) = mCell.innerText
          mColonna = mColonna + 1
        Next mCell
        mRiga = mRiga + 1
      Next mRow
      k = 1
  Next mTable
 
   
 
   Set mIE = CreateObject("InternetExplorer.Application")
  k = 0
  mRiga = 900
  With mIE
    .AddressBar = False
    .StatusBar = False
    .MenuBar = False
    .Toolbar = 0
    .Visible = False
    .navigate "http://www.oddsportal.com/soccer/england/premier-league/results/#/page/5/"

  End With
 
  While mIE.Busy
  Wend
  While mIE.document.readyState <> "complete"
  Wend
 
  Set mTables = mIE.document.all.tags("TABLE")
  For Each mTable In mTables
      Set mRows = mTable.Rows
      For Each mRow In mRows
        Set mCells = mRow.Cells
        If Cells(mRiga - 1, 1) = "" Or Cells(mRiga - 1, 1) = "No." Then
        mColonna = 1
        Else
        mColonna = 1
        End If
        If k = 1 Then mColonna = 1
        For Each mCell In mCells
       
          ActiveSheet.Cells(mRiga, mColonna) = mCell.innerText
          mColonna = mColonna + 1
        Next mCell
        mRiga = mRiga + 1
      Next mRow
      k = 1
  Next mTable
 
 
 
 
 
 
   Set mIE = CreateObject("InternetExplorer.Application")
  k = 0
  mRiga = 1000
  With mIE
    .AddressBar = False
    .StatusBar = False
    .MenuBar = False
    .Toolbar = 0
    .Visible = False
    .navigate "http://www.oddsportal.com/soccer/england/premier-league/results/#/page/6/"

  End With
 
  While mIE.Busy
  Wend
  While mIE.document.readyState <> "complete"
  Wend
 
  Set mTables = mIE.document.all.tags("TABLE")
  For Each mTable In mTables
      Set mRows = mTable.Rows
      For Each mRow In mRows
        Set mCells = mRow.Cells
        If Cells(mRiga - 1, 1) = "" Or Cells(mRiga - 1, 1) = "No." Then
        mColonna = 1
        Else
        mColonna = 1
        End If
        If k = 1 Then mColonna = 1
        For Each mCell In mCells
       
          ActiveSheet.Cells(mRiga, mColonna) = mCell.innerText
          mColonna = mColonna + 1
        Next mCell
        mRiga = mRiga + 1
      Next mRow
      k = 1
  Next mTable
 
 
 
 
 
 
   Set mIE = CreateObject("InternetExplorer.Application")
  k = 0
  mRiga = 1100
  With mIE
    .AddressBar = False
    .StatusBar = False
    .MenuBar = False
    .Toolbar = 0
    .Visible = False
    .navigate "http://www.oddsportal.com/soccer/england/premier-league/results/#/page/7/"

  End With
 
  While mIE.Busy
  Wend
  While mIE.document.readyState <> "complete"
  Wend
 
  Set mTables = mIE.document.all.tags("TABLE")
  For Each mTable In mTables
      Set mRows = mTable.Rows
      For Each mRow In mRows
        Set mCells = mRow.Cells
        If Cells(mRiga - 1, 1) = "" Or Cells(mRiga - 1, 1) = "No." Then
        mColonna = 1
        Else
        mColonna = 1
        End If
        If k = 1 Then mColonna = 1
        For Each mCell In mCells
       
          ActiveSheet.Cells(mRiga, mColonna) = mCell.innerText
          mColonna = mColonna + 1
        Next mCell
        mRiga = mRiga + 1
      Next mRow
      k = 1
  Next mTable
 
 
 
 
 
 
 
  Set mIE = CreateObject("InternetExplorer.Application")
  k = 0
  mRiga = 1200
  With mIE
    .AddressBar = False
    .StatusBar = False
    .MenuBar = False
    .Toolbar = 0
    .Visible = False
    .navigate "http://www.oddsportal.com/soccer/england/premier-league/results/#/page/8/"

  End With
 
  While mIE.Busy
  Wend
  While mIE.document.readyState <> "complete"
  Wend
 
  Set mTables = mIE.document.all.tags("TABLE")
  For Each mTable In mTables
      Set mRows = mTable.Rows
      For Each mRow In mRows
        Set mCells = mRow.Cells
        If Cells(mRiga - 1, 1) = "" Or Cells(mRiga - 1, 1) = "No." Then
        mColonna = 1
        Else
        mColonna = 1
        End If
        If k = 1 Then mColonna = 1
        For Each mCell In mCells
       
          ActiveSheet.Cells(mRiga, mColonna) = mCell.innerText
          mColonna = mColonna + 1
        Next mCell
        mRiga = mRiga + 1
      Next mRow
      k = 1
  Next mTable
 
 
 
 
 
 
 
 
 
  Set mIE = CreateObject("InternetExplorer.Application")
  k = 0
  mRiga = 1300
  With mIE
    .AddressBar = False
    .StatusBar = False
    .MenuBar = False
    .Toolbar = 0
    .Visible = False
    .navigate "http://www.betexplorer.com/soccer/england/premier-league/fixtures/"

  End With
 
  While mIE.Busy
  Wend
  While mIE.document.readyState <> "complete"
  Wend
 
  Set mTables = mIE.document.all.tags("TABLE")
  For Each mTable In mTables
      Set mRows = mTable.Rows
      For Each mRow In mRows
        Set mCells = mRow.Cells
        If Cells(mRiga - 1, 1) = "" Or Cells(mRiga - 1, 1) = "No." Then
        mColonna = 1
        Else
        mColonna = 1
        End If
        If k = 1 Then mColonna = 1
        For Each mCell In mCells
       
          ActiveSheet.Cells(mRiga, mColonna) = mCell.innerText
          mColonna = mColonna + 1
        Next mCell
        mRiga = mRiga + 1
      Next mRow
      k = 1
  Next mTable
 
MsgBox "Ma cu sugnu."
'
End Sub

Ora il mio problema sta nel fatto che quando devo analizzare un altro campionato, devo andare a cambiare tutti i link, chiedevo se era possibile inserire il link all'interno di una cella di un foglio, e prelevarlo direttamente da li, grazie anticipatamente

[Anthony47]

Ci sono state numerose discussioni che vertono su come leggere le tabelle dati da siti web; quello piu' vicino alle tue esigenze potrebe essere questo: viewtopic.php?f=26&t=106072
In particolare potresti usare la Sub GetTabbbSub(ByVal myURL As String) descritta nel secondo dei miei messaggi.

Unica variazione rispetto a quanto lì detto:
-metti il codice in un Modulo del vba a se' stante, ma in testa al modulo aggiungi l'istruzione

Codice: Seleziona tutto

Dim i As Long, TI As Long


Poi in un'area libera del tuo file, esempio in Foglio1 da A2 verso il basso, scrivi tutti gli url delle pagine da consultare.
Infine sullo stesso Modulo vba che contiene la GetTabbbSub inserirai questa ulteriore macro:

Codice: Seleziona tutto

Sub CallX()
Dim j As Long
    Sheets("Foglio1").Select       '<<< Il foglio su cui si fara' l'importazione
    Cells.ClearContents            'NB: Il fofglio SARA' AZZERATO senza preavviso
'
For j = 1 To 100
    If Sheets("Foglio2").Cells(j, "A") <> "" Then
        i = i + 10                  'Spazio aggiuntivo tra le tabelle di ogni pagina
        Call GetTabbbSub(Sheets("Foglio2").Cells(j, "A"))
    Else
        Exit For
    End If
Next j
    Cells.WrapText = False
End Sub


All'occorrenza lancerai la Sub CallX

Se l'elenco si trova in altra colonna, es la B, allora laddove leggi Cells(j, "A") modifica in (indovina?) Cells(j, "B")

Ciao

[gioninos]

Scusami ma le mie capacità in merito ai codici vba si fermano a dei semplici copia e incolla, il codice io lo riportato tutto nel modulo 1 ed esattamente cosi:

Codice: Seleziona tutto

Dim i As Long, TI As Long
Sub GetTabbbSub(ByVal myURL As String)
'Va Chiamata passandogli l'URL da leggere
'myURL = "http://www.nhl.com/stats/team?reportType=game&report=teamsummary&season=20152016&gameType=2&aggregate=1&gameLocation=H"

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
Stop            '*** VEDI Testo
'
myStart = Timer  'attesa addizionale
Do
    DoEvents
    If Timer > myStart + 2 Or Timer < myStart Then Exit Do
Loop

'Leggi le tabelle SUL FOGLIO ATTIVO
''Sheets("Classifica Home").Select
''Cells.Clear
Set myColl = IE.document.getElementsByTagName("TABLE")
For Each myItm In myColl
    Cells(i + 1, 1) = "Table# " & TI + 1
    TI = TI + 1: i = i + 1
    For Each trtr In myItm.Rows
        For Each tdtd In trtr.Cells
            Cells(i + 1, j + 1) = tdtd.innerText
            j = j + 1
        Next tdtd
        i = i + 1: j = 0
DoEvents
    Next trtr

i = i + 1
Next myItm
'
'Chiusura IE
IE.Quit
Set IE = Nothing
End Sub

Sub CallX()
Dim j As Long
    Sheets("Foglio1").Select       '<<< Il foglio su cui si fara' l'importazione
    Cells.ClearContents            'NB: Il fofglio SARA' AZZERATO senza preavviso
'
For j = 1 To 100
    If Sheets("Foglio2").Cells(j, "A") <> "" Then
        i = i + 10                  'Spazio aggiuntivo tra le tabelle di ogni pagina
        Call GetTabbbSub(Sheets("Foglio2").Cells(j, "A"))
    Else
        Exit For
    End If
Next j
    Cells.WrapText = False
End Sub

Inserisco l'URL nella cella A3 del Foglio 1, ma non succede nulla

[Anthony47]

Inserisco l'URL nella cella A3 del Foglio 1, ma non succede nulla

Come detto "All'occorrenza lancerai la Sub CallX": l'hai fatto?

[gioninos]

Allora il codice é inserito giusto, ma lanciando la Sub CallX non succede nulla

[Anthony47]

Ho sbagliato a darti le istruzioni: secondo il codice suggerito le tabelle vengono importate su Foglio1, ma l'elenco di url deve essere scritto su Foglio2, da A2 verso il basso.

Riprova per favore.

[gioninos]

eppure utilizzo la GetwebTab2 ed è un portento, con questa non parte neanche windows explorer,

[Anthony47]

C'e' qualcosa di macroscopico che ci sfugge...
Vai nell'editor delle macro, seleziona una riga della Sub CallX ed esegui la macro passo passo: premi F8 e l'istruzione che va ad eseguirsi (al prossimo F8) sara' evidenziata di Giallo; segui l'evoluzione e dimmi dove fa qualcosa che non ti torna.

Ciao