Modifica Macro Importa Colonna Vincente S.Enalotto

[Francesco6918]

Buona sera a tutti gli amici del forum il mio problema è modificare una macro per importare la colonna vincente della prima riga da una tabella dal sito (LOTTOLOGIA), fino a qualche mese fa funzionava tutto poi il sito è stato aggiornato con delle modifiche grafiche,la colonna vincente veniva importata nel intervallo S9:Y9 compreso il numero jolly il sito inserito nella macro era il seguente : "https://www.lottologia.com/superenalotto/?do=archivio-estrazioni&tab=&date=08-11-2019&year=2019&group_num_selector=selected&numbers_selector_mode=add&numbers_selected=#main" ora è diventato : "https://www.lottologia.com/superenalotto/?do=past-draws-archive&table_view_type=simple&year=2020&numbers=" dunque non riesco a moficare la macro via llego il file con la macro inserita.

Grazie

Saluti

http://www.filedropper.com/importacolonnavincente

[Anthony47]

Senza stravolgere l'impostazione della tua macro:

Codice: Seleziona tutto

Sub Importa_Colonna_Vincente_Singola_2()
Dim html_Content As Object
Dim Web_Url As String
Dim DataDest As String
Dim myDR As Object
Dim myStr As String, I As Long
'
DataDest = "S10"                '<<< La cella a partire da cui si scrivono i risultati
'
'    Application.ScreenUpdating = False
Range(DataDest).Resize(1, 8).ClearContents          'Azzera l'area dei risultati
Range(Cells(2, 1), Cells(9, 9)).ClearContents
Web_Url = "https://www.lottologia.com/superenalotto/?do=past-draws-archive&table_view_type=simple&year=2020&numbers="
Set html_Content = CreateObject("htmlfile")
With CreateObject("msxml2.xmlhttp")
    .Open "GET", Web_Url, False
    .send
    html_Content.Body.Innerhtml = .responseText
End With
Set myDR = html_Content.getElementsByTagName("table")(0).getElementsByTagName("tr")(1)
myStr = Replace(myDR.getElementsByTagName("td")(1).innertext, Chr(13), "", , , vbTextCompare)
For I = 1 To Len(myStr) / 2
    Range(DataDest).Offset(0, I - 1).Value = Mid(myStr, (I - 1) * 2 + 1, 2)
Next I
Range(DataDest).Offset(0, 6).Value = myDR.getElementsByTagName("td")(2).innertext   'Jolly
Range(DataDest).Offset(0, 7).Value = myDR.getElementsByTagName("td")(3).innertext   'Superstar
Set html_Content = Nothing
MsgBox "Importazione Colonna Vincente Singola", vbInformation
Columns("S:Y").ColumnWidth = 5
    Cells(2, 1).Select
End Sub

Prova e fai sapere...

[Francesco6918]

Ciao Anthony47 la macro funziona benissimo eventualmente e possibile importare tuta la tabella tutte le righe, via allego il file con la macro che funzionava prima delle modifiche al sito in cui importavo tutto l archivio 2019. con questo codice nella macro importava tutte le righe del archivio 2019
If iRow = 166 Then GoTo Hop ' decidi quante righe della tabella importare

GRAZIE

Saluti

http://www.filedropper.com/importazione ... alotto2019

[Anthony47]

Se vuoi poter importare piu' estrazioni allora prova questa variante:

Codice: Seleziona tutto

Sub Importa_Colonna_Vincente()
Dim html_Content As Object
Dim Web_Url As String
Dim DataDest As String
Dim myDR As Object, myAllTR As Object
Dim myStr As String, I As Long, J As Long, Limit As Long
'
DataDest = "S10"                '<<< La cella a partire da cui si scrivono i risultati
Limit = 0                       '<<< Il numero di estrazioni da importare; se 0="tutte"
'
Range(Cells(2, 1), Cells(9, 9)).ClearContents
Web_Url = "https://www.lottologia.com/superenalotto/?do=past-draws-archive&table_view_type=simple&year=2020&numbers="
Set html_Content = CreateObject("htmlfile")
With CreateObject("msxml2.xmlhttp")
    .Open "GET", Web_Url, False
    .send
    html_Content.Body.Innerhtml = .responseText
End With
Set myAllTR = html_Content.getElementsByTagName("table")(0).getElementsByTagName("tr")
If Limit = 0 Then Limit = myAllTR.Length Else Limit = Limit + 1
If Limit > myAllTR.Length Then Limit = myAllTR.Length
Range(DataDest).Resize(Limit + 2, 8).ClearContents        'Azzera l'area dei risultati
Application.ScreenUpdating = False
'Ciclo per importare:
For J = 1 To Limit - 1
    Set myDR = myAllTR(J)
    myStr = Replace(myDR.getElementsByTagName("td")(1).innertext, Chr(13), "", , , vbTextCompare)
    For I = 1 To Len(myStr) / 2
        Range(DataDest).Offset(J - 1, I - 1).Value = Mid(myStr, (I - 1) * 2 + 1, 2)
    Next I
    Range(DataDest).Offset(J - 1, 6).Value = myDR.getElementsByTagName("td")(2).innertext 'Jolly
    Range(DataDest).Offset(J - 1, 7).Value = myDR.getElementsByTagName("td")(3).innertext 'Superstar
Next J
Set html_Content = Nothing
Application.ScreenUpdating = True
MsgBox "Completata Importazione Colonna Vincente; estrazioni: " & J - 1, vbInformation
Columns("S:Y").ColumnWidth = 5
    Cells(2, 1).Select
End Sub

Le variabili marcate <<< sono da personalizzare come da commenti
In particolare nella variabile Limit puoi inserire quante righe di estrazioni vuoi importare, oppure 0 se vuoi importare tutte le righe che sono presenti in tabella sul sito

Fai sapere...

[Francesco6918]

Ciao Anthony47 perfetto funziona al momento riguardo l importazione delle colonne S.Enalotto è tutto risolto, inseguito vorrei risolvere il problema riguardo l importazione delle colonne vincente del 10 E Lotto sempre sul sito Lottologia in passato usavo la stessa macro del S.Enalotto modificata per il 10 E Lotto ma anche in questa pagina ci sono state modifiche sito : https://www.lottologia.com/10elotto/?do ... 0&numbers=
in precedenza la prima riga conteneva tutti e 20 numeri attualmente la prima riga contiene i primi 10 numeri e sotto i restanti 10 è piu difficile applicando la tua macro funziona ma ho notato una colonna vuota AC9, non so quale modifica dovrei applicare propongo il file ?con la tua macro, sempre se c'è disponibilità


Ti ringrazio

Saluti

https://app.mediafire.com/myfiles

[Anthony47]

Il link che hai pubblicato porta alla home page di mediafire.com, non consente di scaricare nessun file.

Comunque mi pare che la seguente versione di macro consenta di scaricare sia da Superenelotto che 10 e lotto, a seconda del valore che imposti in Web_Url:

Codice: Seleziona tutto

Sub Importa_Colonna_Vincente()
Dim html_Content As Object
Dim Web_Url As String
Dim DataDest As String
Dim myDR As Object, myAllTR As Object
Dim myStr As String, I As Long, J As Long, Limit As Long
'
DataDest = "S10"                '<<< La cella a partire da cui si scrivono i risultati
Limit = 100                       '<<< Il nume di estrazioni da importare; se 0="tutte"
'
Range(Cells(2, 1), Cells(9, 9)).ClearContents
''Web_Url = "https://www.lottologia.com/superenalotto/?do=past-draws-archive&table_view_type=simple&year=2020&numbers="  'Superenalotto
Web_Url = "https://www.lottologia.com/10elotto/?do=past-draws-archive&table_view_type=simple&year=2020&numbers="        '10 e lotto
Set html_Content = CreateObject("htmlfile")
With CreateObject("msxml2.xmlhttp")
    .Open "GET", Web_Url, False
    .send
    html_Content.Body.Innerhtml = .responseText
End With
Set myAllTR = html_Content.getElementsByTagName("table")(0).getElementsByTagName("tr")
If Limit = 0 Then Limit = myAllTR.Length Else Limit = Limit + 1
If Limit > myAllTR.Length Then Limit = myAllTR.Length
Range(DataDest).Resize(Limit + 2, 23).ClearContents        'Azzera l'area dei risultati
Application.ScreenUpdating = False
'Ciclo per importare:
For J = 1 To Limit - 1
    Set myDR = myAllTR(J)
    myStr = Replace(myDR.getElementsByTagName("td")(1).innertext, Chr(13), "", , , vbTextCompare)
    myStr = Replace(myStr, Chr(10), "", , , vbTextCompare)
    For I = 1 To Len(myStr) / 2
        Range(DataDest).Offset(J - 1, I - 1).Value = Mid(myStr, (I - 1) * 2 + 1, 2)
    Next I
    Range(DataDest).Offset(J - 1, I - 1).Value = myDR.getElementsByTagName("td")(2).innertext   'Jolly /Gold
    Range(DataDest).Offset(J - 1, I).Value = myDR.getElementsByTagName("td")(3).innertext       'Superstar  /Gold
Next J
Set html_Content = Nothing
Application.ScreenUpdating = True
MsgBox "Importazione Colonna Vincente; estrazioni: " & J - 1, vbInformation
Columns("S:Y").ColumnWidth = 5
    Cells(2, 1).Select
End Sub

Eventualmente potresti impostare un url oppure l'altro a seconda del Foglio in cui ti trovi.

Fai sapere...

[Francesco6918]

Ciao Anthony47 scusa ma ieri sera non riuscivo a caricare il file sul sito filedropper ora ci sono riuscito allego il file comunque la tua macro per il 10 e Lotto funziona salvo problemi tutto funziona alla perfezione .

Saluiti

Grazie

http://www.filedropper.com/importacolon ... te10elotto