Macro per importare dati dalla Lottomatica.

[nelson1331]

Ciao Anthony47,
questa volta ti chiedo un aiuto, per importare i dati dalla Lottomatica.
Utilizzo queste 2 macro (e quindi sono funzionanti) ma, da circa 2 settimane, hanno modificato dei parametri e non vogliono piu' riportarle ai valori precedenti.
Siccome ho migliaia di fogli excel che lavorano sullo standard precedente, vorrei poter risolvere il problema, senza dover modificare tutti i fogli.
Il sistema operativo e' Windows10.
Il browser e' Google Chrome.
La versione di excel e' 2010.
In pratica, dopo la colonna "A" che contiene le date, nella colonna "B", esisteva un identificativo dell' estrazione, che partiva da 1 all' inizio del mese e poi veniva incrementato col +1 ad ogni estrazione e che poi ripartiva ancora una volta da 1 con incremento +1 ad ogni cambio del mese.
I dati delle estrazioni partivano dalla colonna "C" e finivano alla colonna "BE". (forma esatta)
Questo identificativo adesso e' stato eliminato e su di esso vi hanno sovrapposto i 55 estratti.
Questo e' cio' che adesso mi crea gravi difficolta' nella lettura dei dati, avendoli shiftati di 1 posizione a sinistra.
Adesso i dati delle estrazioni, partono dalla colonna "B" e finiscono nella colonna "BD". (forma errata)
Se puoi indirizzarmi affinche' riesca ad eliminare tale problema, te ne sono grato.
Nelson

Ecco le 2 macro :
Sub Aggiorna()
Call Web
'Application.Goto Reference:="Web"
End Sub

Sub Web()
Application.ScreenUpdating = False
Sheets("Archivio").Select
Range("A1:BE10000") = ""
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://lottoscar.altervista.org/ArchivioLotto.italia.csv", Destination:=Range("$A$1"))
.Name = "?action=Archivio"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlAllTables
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
'------------------------------------------------------- Scompattazione archivio
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 4)), TrailingMinusNumbers:=True
Range("A1").Select
Selection.ColumnWidth = 13
Range("B1").Select
Selection.ColumnWidth = 5
Range("C1:BE1").Select
Selection.ColumnWidth = 3
Range("A1").Select
Sheets("Homepage").Select
MsgBox "Aggiornato archivio terminato ! ! !", vbInformation
End Sub

[Anthony47]

Allora…
Non mi e’ chiaro il formato che chiedi, comunque mi permetto di modificare la tua macro funzionante come segue:

Codice: Seleziona tutto

Sub Lottolo()
Sheets("Archivio").Select
Range("A1:BE10000").ClearContents
'Apre archivio on-line:
Workbooks.Open "http://lottoscar.altervista.org/ArchivioLotto.italia.csv"
'
'Copia e Scompattazione archivio
Range("A1").CurrentRegion.Copy ThisWorkbook.Sheets("Archivio").Range("A1")
ActiveWorkbook.Close False
Range("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 4)), TrailingMinusNumbers:=True
Range("A1").Select
Selection.ColumnWidth = 13
Range("B1").Select
Selection.ColumnWidth = 5
Range("C1:BE1").Select
Selection.ColumnWidth = 3
'Inserisce colonna #estrazione
Columns("B:B").Insert Shift:=xlToRight
'
'Msg finale
Sheets("Homepage").Select
MsgBox "Aggiornato archivio terminato ! ! !", vbInformation

End Sub


Come vedi ho eliminato la “connessione” al file da importare, che essendo un .csv puo’ essere aperto direttamente e poi copiato nel foglio Archivio; qui si fa la “scompattazione in colonne” (che peraltro potrebbe non essere piu’ necessaria dopo la prima volta) e poi aggiungo la colonna B che pero’ al momento rimane vuota.
Probabilmente, se mi fai capire che cosa dovrebbe esserci scritto, la si puo’ compilare con altre istruzioni della macro; aspetto quindi tuoi chiarimenti su questa operazione.
Uno dei motivi per cui ho eliminato la “connessione” e’ che, operando con Add (connessione) il tuo file conterra’ sempre piu’ connessioni e prima o poi raggiungerai il limite tollerato (forse sono 1000)

Ciao

[nelson1331]

Ciao Anthony47.
Ho fatto 2 tipi di prove.
1° prova : ho mantenuto i dati preesistenti ed ho fatto l' aggiornamento con la tua macro, e si e' comportato correttamente.
Ha aggiunto l' ultima riga, andando ad aggiornare correttamente data ed estratti in modo corretto, nelle posizioni giuste.
2° prova : ho cancellato tutte le righe, lasciando solo quella iniziale e poi ho lanciato la tua macro.
In questo caso sbaglia, poiche' (avendola ripetuta piu' volte, ho notato il medesimo comportamento), va a scrivere nelle colonne "C" e "D", date del calendario, anziche' valori degli estratti.
Cosa dovrebbe contenere la colonna "B", per ora vuota ?
Dovra' contenere un indice di estrazione progressivo, che parte da 1 con la riga iniziale (cioe' casella B2) e poi dovra' incrementarsi col +1, rimanendo nell' ambito dello stesso mese, relativo alla data che compare a sinistra (colonna "A").
Se il mese della riga precedente e' identico, allora aggiunge +1 (incrementa l' indice dell' estrazione).
Se invece il mese della riga precedente e' diverso dalla riga corrente, allora vuol dire che cambia il mese e dovra' fare cosi : riparte da 1 ed all' avanzare delle estrazioni, ancora una volta, incrementa col +1
Adesso ti faccio lo schema dei contenuti delle prime 9 righe, cosi' potrai confrontarle.
Data........Indice
7.1.1939...1 (per default, parte sulla 1° riga con l' unita')
14.1.1939..2
21.1.1939..3
28.1.1939..4
4.2.1939....1 (ricomincia daccapo, dall' unita')
11.2.1939..2
18.2.1939..3
25.2.1939..4
4.3.1939....1 (ricomincia daccapo, dall' unita')

[Anthony47]

Quelle "date" in B e C sono solo effetto di una formattazione sbagliata (ereditata da colonna A).
Ho aggiunto alla macro principale una istruzione per formattare "Generale" le colonne B:F, ho aggiunto una sub per popolare colonna B e la richiamo dalla macro principale.
Il nuovo codice complessivo:

Codice: Seleziona tutto

Sub Lottolo()
Sheets("Archivio").Select
Range("A1:BE10000").ClearContents
'Apre archivio on-line:
Workbooks.Open "http://lottoscar.altervista.org/ArchivioLotto.italia.csv"
'
'Copia e Scompattazione archivio
Range("A1").CurrentRegion.Copy ThisWorkbook.Sheets("Archivio").Range("A1")
ActiveWorkbook.Close False
Range("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 4)), TrailingMinusNumbers:=True
Range("A1").Select
Selection.ColumnWidth = 13
Range("B1").Select
Selection.ColumnWidth = 5
Range("C1:BE1").Select
Selection.ColumnWidth = 3
'Inserisce colonna #estrazione
Columns("B:B").Insert Shift:=xlToRight
Columns("B:F").NumberFormat = "General"
Call FillColB(1)
'
'Msg finale
Sheets("Homepage").Select
MsgBox "Aggiornato archivio terminato ! ! !", vbInformation

End Sub


Sub FillColB(dummy)
'Popola colonna B
Dim WArr, BArr() As Integer, I As Long
Dim oMon As Integer, bCnt As Integer
'
WArr = Range(Range("A2"), Range("A2").End(xlDown)).Value
ReDim BArr(1 To UBound(WArr), 1 To 1)
For I = 1 To UBound(WArr)
    If Month(WArr(I, 1)) = oMon Then
        bCnt = bCnt + 1
    Else
        bCnt = 1
        oMon = Month(WArr(I, 1))
    End If
    BArr(I, 1) = bCnt
Next I
Range("B2").Resize(UBound(BArr), 1).Value = BArr
End Sub


Ciao

[nelson1331]

1° valutazione generale : mi sembra tutto a posto ed in ordine.
Dovro' fare alcune verifiche (e ti riferiro' successivamente), pero' da quanto ho notato tutte le funzionalita' precedenti, sono state ripristinate.
Una domanda in piu' sull' argomento : se volessi staccarmi definitivamente dall' archivio all' indirizzo, Lottoscar, cosa devo fare ?
Una volta in piu' per dirti grazie per tutto cio' che offri come aiuto gratuito.
Un augurio per la tua giornata ed usero' una frase con un saluto tibetano :
Tashi Delek.

[Anthony47]

Per cancellare eventuali query rimaste inserite nel tuo file, vai su foglio Archivio, seleziona tutte le celle (clicca sul triangolino in alto sx di A1) e premi Canc; probabilmente ti dira' che ci sono delle query associate e chiede se vui cancellare anche quelle, e risponderai di Sì.
Poi va su Menu /Formule /Gestione Nomi; se si sono dei "Nomi" che non hai creato tu cancellali (li selezioni, premi Elimina)

Ciao

[nelson1331]

Ciao Anthony47.
Hanno eliminato il seguente link.
"http://lottoscar.altervista.org/ArchivioLotto.italia.csv"
Se puoi darmi alcune dritte (se esistono dei video o se hai gia' realizzato qualcosa del genere), ti chiedo di fornirmi alcune spiegazioni in piu' per come procedere e superare l' ostacolo, affinche' possa crearmi la macro dall' a-z, per poter aggiornare regolarmente i fogli excel.
Grazie.
Nelson

[Anthony47]

Non ho capito... Ma adesso il tuo archivio riesci ad aggiornarlo o no?

[nelson1331]

No. Non si aggiornano piu' gli archivi.

[Anthony47]

Ma il problema e' che il sito che ti forniva l'archivio ora lo fornisce sotto forma di file zippato...

Si puo' aggirare scaricando il file zippato, espandendolo e poi procedendo come prima.

Il nuovo codice complessivo:

Codice: Seleziona tutto

#If VBA7 Then
    Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
        Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, _
        ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#Else
    Private Declare Function URLDownloadToFile Lib "urlmon" _
    Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, _
    ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#End If


Sub Lottololo()
Dim ZipPath As String, Ret As Variant, mySplit
'
Sheets("Archivio").Select
Range("A1:BE10000").ClearContents
'Scarica file .zip:
'
'>>>> PARTE MODIFICATA:
ZipPath = "C:\prova\"                       '<<< Una tua directory dove scaricare il file zippato
'
Ret = GetWebFile("http://lottoscar.altervista.org/ArchivioLotto.italia.zip", ZipPath)
If Ret = 0 Then
    MsgBox ("Import .zip fallito. Processo abortito")
Else
    Debug.Print "GetWebFile=" & Ret
End If
'
'Espandi .zip:
Call FileDeZip(Ret, ZipPath)
mySplit = Split("\ " & Ret, "\", , vbTextCompare)
'Apre archivio on-line:
Workbooks.Open ZipPath & "\" & "ArchivioLotto.italia.csv"
'<<<< Fine parte Modificata
'
'Copia e Scompattazione archivio
Range("A1").CurrentRegion.Copy ThisWorkbook.Sheets("Archivio").Range("A1")
ActiveWorkbook.Close False
Range("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 4)), TrailingMinusNumbers:=True
Range("A1").Select
Selection.ColumnWidth = 13
Range("B1").Select
Selection.ColumnWidth = 5
Range("C1:BE1").Select
Selection.ColumnWidth = 3
'Inserisce colonna #estrazione
Columns("B:B").Insert Shift:=xlToRight
Columns("B:F").NumberFormat = "General"
Call FillColB(1)
'
'Msg finale
Sheets("Homepage").Select
MsgBox "Aggiornato archivio terminato ! ! !", vbInformation

End Sub


Sub FillColB(dummy)
'Popola colonna B
Dim WArr, BArr() As Integer, I As Long
Dim oMon As Integer, bCnt As Integer
'
WArr = Range(Range("A2"), Range("A2").End(xlDown)).Value
ReDim BArr(1 To UBound(WArr), 1 To 1)
For I = 1 To UBound(WArr)
    If Month(WArr(I, 1)) = oMon Then
        bCnt = bCnt + 1
    Else
        bCnt = 1
        oMon = Month(WArr(I, 1))
    End If
    BArr(I, 1) = bCnt
Next I
Range("B2").Resize(UBound(BArr), 1).Value = BArr
End Sub

 
Function GetWebFile(ByVal myURL, ByVal myPath As String) As Variant
'byAnthony, ritorna Image Path & name OPPURE 0 se fail
Dim PathNName As String, URL As String
Dim mySplit, Resp As Long
mySplit = Split(myURL, "/")
PathNName = myPath & mySplit(UBound(mySplit))
Resp = URLDownloadToFile(0, myURL, PathNName, 0, 0)
If Resp = 0 Then
    GetWebFile = PathNName
    Exit Function
Else
    GetWebFile = 0
End If
End Function


Sub FileDeZip(ByVal fName As Variant, dzPath As Variant)
'Dim ZipFile As String, OutPath As String, ZipPath As String
'
Set sh = CreateObject("Shell.Application")
    sh.Namespace(dzPath & "").CopyHere sh.Namespace(fName).Items   ''', 16       '16=Overwrite stesso nome
Set sh = Nothing
End Sub


Metti il tutto in un Modulo standard vuoto; personalizza la riga marcata <<<
Noterai la presenza di una dichiarazione iniziale, di una Function GetWebFile (che useremo per scaricare il file .zip) e una Sub FileDeZip (che useremo per scompattare il file .zip)

Lancia poi la Sub Lottololo e probabilmente otterrai lo stesso risultato che ottenevi prima

Fai sapere...

[nelson1331]

Ciao Anthony47,
tutto ha girato senza problemi ma, come noterai dalla 2° immagine, i contenuti, non sono corrispondenti alla 1° immagine.
Forma corretta :
https://1drv.ms/u/s!ApTdq9BQgwZZnUFB-LztTx6gZO3B

Forma errata, decomprimendo il file zippato e poi eseguendo la macro Lottolo :
https://1drv.ms/u/s!ApTdq9BQgwZZnUImw65atFza6WlO

[Anthony47]

Faccio volentieri un ultimo adattamento per andare dietro al diverso formato dati del tuo fornitore.

In particolare al codice precedente (che scaricava il file zippato e successivamente ne estraeva il contenuto) ho aggiunto una Sub EXP, che si occupa di adattare il nuovo formato al vecchio.
Il nuovo codice complessivo, da inserire in un modulo vba standard inizialmente vuoto, in modo che l’istruzione #If VBA7 Then capiti in testa al modulo:

Codice: Seleziona tutto

#If VBA7 Then
    Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
        Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, _
        ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#Else
    Private Declare Function URLDownloadToFile Lib "urlmon" _
    Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, _
    ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#End If


Sub Lottololo()
Dim ZipPath As String, Ret As Variant, mySplit
'
Sheets("Archivio").Select
Range("A1:BE10000").ClearContents
'Scarica file .zip:
'
'>>>> PARTE MODIFICATA:
ZipPath = "C:\prova\"                       '<<< Una tua directory dove scaricare il file zippato
'
Ret = GetWebFile("http://lottoscar.altervista.org/ArchivioLotto.italia.zip", ZipPath)
If Ret = 0 Then
    MsgBox ("Import .zip fallito. Processo abortito")
Else
    Debug.Print "GetWebFile=" & Ret
End If
'
'Espandi .zip:
Call FileDeZip(Ret, ZipPath)
mySplit = Split("\ " & Ret, "\", , vbTextCompare)
'Apre archivio on-line:
Workbooks.Open ZipPath & "\" & "ArchivioLotto.italia.csv"
'<<<< Fine parte Modificata
'
'Copia e Scompattazione archivio
Range("A1").CurrentRegion.Copy ThisWorkbook.Sheets("Archivio").Range("A1")
ActiveWorkbook.Close False
Range("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 4)), TrailingMinusNumbers:=True
'
Call EXP
'
Range("A1").Select
Selection.ColumnWidth = 13
Range("B1").Select
Selection.ColumnWidth = 5
Range("C1:BE1").Select
Selection.ColumnWidth = 3
'Inserisce colonna #estrazione
Columns("B:B").Insert Shift:=xlToRight
Columns("B:F").NumberFormat = "General"
Call FillColB(1)
Range("A1:B1") = Array("Data", "Indice")
'
'Msg finale
Sheets("Homepage").Select
MsgBox "Aggiornato archivio terminato ! ! !", vbInformation
End Sub


Sub FillColB(dummy)
'Popola colonna B
Dim wArr, BArr() As Integer, I As Long
Dim oMon As Integer, bCnt As Integer
'
wArr = Range(Range("A2"), Range("A2").End(xlDown)).Value
ReDim BArr(1 To UBound(wArr), 1 To 1)
For I = 1 To UBound(wArr)
    If Month(wArr(I, 1)) = oMon Then
        bCnt = bCnt + 1
    Else
        bCnt = 1
        oMon = Month(wArr(I, 1))
    End If
    BArr(I, 1) = bCnt
Next I
Range("B2").Resize(UBound(BArr), 1).Value = BArr
End Sub

 
Function GetWebFile(ByVal myURL, ByVal myPath As String) As Variant
'byAnthony, ritorna Image Path & name OPPURE 0 se fail
Dim PathNName As String, URL As String
Dim mySplit, Resp As Long
mySplit = Split(myURL, "/")
PathNName = myPath & mySplit(UBound(mySplit))
Resp = URLDownloadToFile(0, myURL, PathNName, 0, 0)
If Resp = 0 Then
    GetWebFile = PathNName
    Exit Function
Else
    GetWebFile = 0
End If
End Function


Sub FileDeZip(ByVal fName As Variant, dzPath As Variant)
'Dim ZipFile As String, OutPath As String, ZipPath As String
'
Set sh = CreateObject("Shell.Application")
    sh.Namespace(dzPath & "").CopyHere sh.Namespace(fName).Items, 16          '16=Overwrite same name
Set sh = Nothing
End Sub


Sub EXP()
Dim myR, wArr, vInd As Long, cR As String
Dim oArr()
Dim I As Long, myMatch, J As Long, OldD As Date
Dim DeSh As Worksheet
'
myR = Array("BA", "CA", "FI", "GE", "MI", "NA", "PA", "RO", "TO", "VE", "NZ")
Set DeSh = ThisWorkbook.Sheets("Archivio")
'
wArr = Range("A1").CurrentRegion
ReDim oArr(1 To UBound(wArr), 1 To (UBound(myR) + 1) * 5 + 1)
For I = 0 To UBound(myR)
    DeSh.Range("B1").Offset(0, I * 5).Resize(1, 5) = myR(I)
Next I
For I = 1 To UBound(wArr)
    If wArr(I, 1) <> OldD Then
        vInd = vInd + 1
        OldD = wArr(I, 1)
        oArr(vInd, 1) = OldD
    End If
    cR = wArr(I, 2)
    myMatch = Application.Match(wArr(I, 2), DeSh.Range("A1").Resize(1, 60), False)
    If Not IsError(myMatch) Then
        For J = 0 To 4
            oArr(vInd, myMatch + J) = wArr(I, 3 + J)
        Next J
    End If
    DoEvents
Next I
DeSh.Range("A2").Resize(UBound(oArr), UBound(oArr, 2)).Value = oArr
End Sub


Come gia’ detto, devi indicare una directory valida in cui verra’ scaricato il file zippato e ne verra’ estratto il contenuto (vedi istruzione marcata <<<)
Poi lancerai la nuova Sub Lottololo; il tempo di esecuzione sara’ di parecchi secondi, occupati dalla conversione di formato. Un msgbox informera’ del completamento delle operazioni.

Prova...

[nelson1331]

Ciao Anthony47,
ho fatto girare il tutto e ti segnalo le seguenti caratteristiche : (se devi fare verifiche, usa l' immagine corretta che avevo gia' postato ieri).
In questa immagine, noterai che mancano le estrazioni :
07.01.1939
14.01.1939
21.01.1939
28.01.1939 Mancano gli estratti di Bari e Firenze.
https://1drv.ms/f/s!ApTdq9BQgwZZnUWve9nDvuEIStDj
Nella 2° immagine, vedrai che senza una valida ragione ha mischiato le date del 2020.
Cioe' ha mischiato date dell' anno 1951 con 2 date del 2020.
https://1drv.ms/u/s!ApTdq9BQgwZZnUSVhXlb6deM4EqZ
Poi ho fatto i controlli completi date ed estratti, fra quello che risulta dall' archivio corretto e quello che ho ottenuto con la tua macro.
Si sono verificati 4 casi, nei quali i valori da te collocati non corrispondono all' archivio corretto. Non ho inserito le immagini ma, nel caso fossero utili ti mandero' anche quelle.
Per avere la certezza di quanto scritto, ho controllato le voci, con gli archivi veri della Lottomatica e ti confermo quanto segue :
Data 22.07.2021 55° posizione (5° estratto Nazionale) Il valore esatto e' 8 mentre tu scrivi 5
Data 27.07.2021 50° posizione (5° estratto Venezia) Il valore esatto e' 28 mentre tu scrivi 29
Data 18.09.2021 33° posizione (3° estratto Palermo) Il valore esatto e' 31 mentre tu scrivi 32
Data 28.09.2021 20° posizione (5° estratto Genova) Il valore esatto e' 61 mentre tu scrivi 16
Altro particolare, che non so se potra' esserti utile ma, che desidero segnalarti ugualmente : dal 4 maggio 2005 la Lottomatica ha inserito l' 11° ruota ossia la Nazionale.
Percio' i campi degli estratti che prima erano 50, da quel momento in poi passano a 55.
Tralasciando le date del 1951, nel quale si sono mischiate 2 date del 2020, tutti gli altri caratteri che ho controllato uno per uno, risultano essere esattamente uguali.
Grazie ancora per l' aiuto che potrai fornirmi.
Nelson

[Anthony47]

Dovresti pero' confrontare l'esito con quanto pubblicato su lottoscar.altervista.org visto che e' lì che prelevi i dati, non con l'archivio ufficiale lottomatica

[nelson1331]

Si' certo Anthony47 : ho fatto entrambi i controlli incrociati.

[Anthony47]

Si' certo Anthony47 : ho fatto entrambi i controlli incrociati.

E allora avrai notato che le mancanze e gli errori che avevi citato sono nell'archivio lottoscar, non nella procedura che li scarica e li presenta, io posso farci poco.
Eventualmente tu puoi partire da un archivio precedente e accodarci solo le estrazioni mancanti.

Faccio volentieri un ultimo adattamento per andare dietro al diverso formato dati del tuo fornitore

In genere dico "penultimo adattamento", e infatti ho fatto male a scrivere "ultimo adattamento". Infatti, avendo fatto 30 tanto vale fare 31...

QUINDI:
Ho aggiunto una Sub SortByData per riposizionare le date sballate nell'archivio lottoscar.
Ho immaginato che aggiungi al tuo file un foglio chiamato ArchivioLS, che useremo per le importazioni da lottoscar
Ho modificato il codice precedente perche' lavori sul foglio ArchivioLS (invece che Archivio)
Ho aggiunto una Sub LS_to_Archivio che copia su Archivio eventuali righe nuove importate in ArchivioLS

Il codice complessivo di questa "ultima versione":

Codice: Seleziona tutto

#If VBA7 Then
    Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
        Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, _
        ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#Else
    Private Declare Function URLDownloadToFile Lib "urlmon" _
    Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, _
    ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#End If


Sub Lottololast()
Dim ZipPath As String, Ret As Variant, mySplit
'
Sheets("ArchivioLS").Select
Range("A1:BE100000").ClearContents
'Scarica file .zip:
'
'>>>> PARTE MODIFICATA:
ZipPath = "C:\prova\"                       '<<< Una tua directory dove scaricare il file zippato
'
Ret = GetWebFile("http://lottoscar.altervista.org/ArchivioLotto.italia.zip", ZipPath)
If Ret = 0 Then
    MsgBox ("Import .zip fallito. Processo abortito")
Else
    Debug.Print "GetWebFile=" & Ret
End If
'
'Espandi .zip:
Call FileDeZip(Ret, ZipPath)
mySplit = Split("\ " & Ret, "\", , vbTextCompare)
'Apre archivio on-line:
Workbooks.Open ZipPath & "\" & "ArchivioLotto.italia.csv"
'<<<< Fine parte Modificata
'
'Copia e Scompattazione archivio
Range("A1").CurrentRegion.Copy ThisWorkbook.Sheets("ArchivioLS").Range("A1")
ActiveWorkbook.Close False
Range("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 4)), TrailingMinusNumbers:=True
'
Call SortByData
'
Call EXP
'
Range("A1").Select
Selection.ColumnWidth = 13
Range("B1").Select
Selection.ColumnWidth = 5
Range("C1:BE1").Select
Selection.ColumnWidth = 3
'Inserisce colonna #estrazione
Columns("B:B").Insert Shift:=xlToRight
Columns("B:F").NumberFormat = "General"
Call FillColB(1)
Range("A1:B1") = Array("Data", "Indice")
'
Call LS_to_Archivio
'
'
'Msg finale
Sheets("Homepage").Select
MsgBox "Aggiornato archivio terminato ! ! !", vbInformation
End Sub


Sub FillColB(dummy)
'Popola colonna B
Dim wArr, BArr() As Integer, I As Long
Dim oMon As Integer, bCnt As Integer
'
wArr = Range(Range("A2"), Range("A2").End(xlDown)).Value
ReDim BArr(1 To UBound(wArr), 1 To 1)
For I = 1 To UBound(wArr)
    If Month(wArr(I, 1)) = oMon Then
        bCnt = bCnt + 1
    Else
        bCnt = 1
        oMon = Month(wArr(I, 1))
    End If
    BArr(I, 1) = bCnt
Next I
Range("B2").Resize(UBound(BArr), 1).Value = BArr
End Sub

 
Function GetWebFile(ByVal myUrl, ByVal myPath As String) As Variant
'byAnthony, ritorna Image Path & name OPPURE 0 se fail
Dim PathNName As String, URL As String
Dim mySplit, Resp As Long
mySplit = Split(myUrl, "/")
PathNName = myPath & mySplit(UBound(mySplit))
Resp = URLDownloadToFile(0, myUrl, PathNName, 0, 0)
If Resp = 0 Then
    GetWebFile = PathNName
    Exit Function
Else
    GetWebFile = 0
End If
End Function


Sub FileDeZip(ByVal fName As Variant, dzPath As Variant)
'Dim ZipFile As String, OutPath As String, ZipPath As String
'
Set sh = CreateObject("Shell.Application")
    sh.Namespace(dzPath & "").CopyHere sh.Namespace(fName).Items, 16          '16=Overwrite same name
Set sh = Nothing
End Sub


Sub EXP()
Dim myR, wArr, vInd As Long, cR As String
Dim oArr()
Dim I As Long, myMatch, J As Long, OldD As Date
Dim DeSh As Worksheet
'
myR = Array("BA", "CA", "FI", "GE", "MI", "NA", "PA", "RO", "TO", "VE", "NZ")
Set DeSh = ThisWorkbook.Sheets("ArchivioLS")
'
wArr = Range("A1").CurrentRegion
ReDim oArr(1 To UBound(wArr), 1 To (UBound(myR) + 1) * 5 + 1)
For I = 0 To UBound(myR)
    DeSh.Range("B1").Offset(0, I * 5).Resize(1, 5) = myR(I)
Next I
For I = 1 To UBound(wArr)
    If wArr(I, 1) <> OldD Then
        vInd = vInd + 1
        OldD = wArr(I, 1)
        oArr(vInd, 1) = OldD
    End If
    cR = wArr(I, 2)
    myMatch = Application.Match(wArr(I, 2), DeSh.Range("A1").Resize(1, 60), False)
    If Not IsError(myMatch) Then
        For J = 0 To 4
            oArr(vInd, myMatch + J) = wArr(I, 3 + J)
        Next J
    End If
    DoEvents
Next I
DeSh.Range("A2").Resize(UBound(oArr), UBound(oArr, 2)).Value = oArr
End Sub

Sub SortByData()
'
    Columns("A:G").Select
    ActiveWorkbook.Worksheets("ArchivioLS").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("ArchivioLS").Sort.SortFields.Add2 Key:=Range( _
        "A1:A100000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("ArchivioLS").Sort
        .SetRange Range("A1:G100000")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A1").Select
End Sub


Sub LS_to_Archivio()
Dim LS As Worksheet, ARCH As Worksheet
Dim lastD As Date, myMatch, lsDown As Long
'
Set LS = Sheets("ArchivioLS")
Set ARCH = Sheets("Archivio")
lastD = Application.WorksheetFunction.Max(ARCH.Range("A:A"))
myMatch = Application.Match(CLng(lastD), LS.Range("A:A"), False)
lsDown = LS.Cells(myMatch, 1).End(xlDown).Row
If lsDown < Rows.Count Then
    LS.Range(LS.Cells(myMatch, 1), LS.Cells(lsDown, 1)).Resize(, 58).Copy _
      Destination:=ARCH.Cells(Rows.Count, 1).End(xlUp)
    MsgBox ("Righe importate: " & (lsDown - myMatch))
Else
    MsgBox ("Non ci sono nuove righe da importare")
End If

End Sub


Eventualmente, dopo collaudo esaustivo, puoi cancellare il contenuto di ArchivioLS per ridurre la dimensione del file

[nelson1331]

Ciao Anthony47.
Ho fatto diversi tentativi ma, gli errori che avevo gia' segnalato, persistono.
Provero' ancora per vedere se esiste un rimedio, altrimenti non vorro' portarti via altro tempo.
Grazie ancora per il tuo impegno.
Nelson

[Anthony47]

Se non sbaglio gli errori riguardano la mancanza di molte estrazioni su molte ruote ma con date molto vecchie; pertanto se parti da un archivio completo ma magari fermo al primo di giugno e poi usi la procedura per leggere da “lottoscar” e accodare sul tuo archivio solo le righe mancanti non dovresti avere un archivio complessivo completo?
A meno che lottoscar non abbia dei buchi anche nelle estrazioni correnti...

[nelson1331]

Ciao Anthony47.
Ti aggiorno sulla situazione che sono riuscito ad ottenere con l' aiuto di Salvatore.
www.archivioestrazionilotto.it
Questo e' il sito che ho scelto per prelevare le estrazioni, con la fiducia che non faccia gli scherzi dello stupido Oscar.
Adesso ho esattamente la configurazione originale : il tracciato record cosi' costruito va benissimo e ricalca fedelmente quanto fatto in origine.
Esiste questo inconveniente : per inserire l' estrazione, ho necessita' di scrivere la data.
Puoi superare questo ostacolo, cioe' aggiornare senza l' inserimento manuale della data ?
Chiedo inoltre che questa macro, senza l' uso della digitazione della macro, possa aggiornare "n" estrazioni a ritroso, indipendentemente da quelle assenti.
Se puoi dare un' occhiata in generale, per renderlo un po' piu' veloce nell' esecuzione, mi fara' piacere.
Grazie ancora per i tuoi suggerimenti.
Nelson

Queste sono le 2 macro :
Sub Aggiorna()
Call Web
'Application.Goto Reference:="Web"
End Sub

Sub Web()
Dim r, c, x, y, k, t, rng, sh1 As Worksheet
Application.ScreenUpdating = False
k = InputBox("Inserisci la data dell'estrazione")
k = CDate(k)
If k = "" Then GoTo 1
Set sh1 = Worksheets("Archivio")
sh1.Activate
r = Cells(Rows.Count, 1).End(xlUp).Row + 1
If k = Cells(r - 1, 1) Then GoTo 1
Range("CA1:CM13").Delete Shift:=xlUp
Application.CutCopyMode = False
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;https://www.archivioestrazionilotto.it", Destination:=Range("$CA$1"))
' .CommandType = 0
.Name = "www.archivioestrazionilotto.it"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "2"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
If t = [ca1] Then GoTo 1
rng = Range("CB2:CF12")
c = 3
Cells(r, 1) = k
Cells(r, 2) = r - 1
For x = 1 To 11
For t = 1 To 5
sh1.Cells(r, c) = rng(x, t)
c = c + 1
Next t
Next x
Cells(r, 1).Select
MsgBox "Estrazione Aggiornata", vbInformation, "Aggiornamento estrazioni"
1:
Sheets("Homepage").Select
Application.ScreenUpdating = True
End Sub

[Anthony47]

Esiste questo inconveniente : per inserire l' estrazione, ho necessita' di scrivere la data.
Puoi superare questo ostacolo, cioe' aggiornare senza l' inserimento manuale della data ?

Se si tratta di importare l'ultima estrazione, allora si puo' fare senza dover indicare "a mano" la data a cui si riferisce. Ma quella macro ha un paio di errori (di impostazione) che rapidamente potrebbero rendere il tuo file ingestibile; quindi sono necessari interventi piu' ampi che subordino ai chiarimenti sulla tua seconda richiesta

Chiedo inoltre che questa macro, senza l' uso della digitazione della macro, possa aggiornare "n" estrazioni a ritroso, indipendentemente da quelle assenti.

Si puo' fare qualcosa sfruttando una strana caratteristica del sito che puo' aiutare. Ad esempio andare all'indietro fino a una data preimpostata

Ma la cosa mi richiede del tempo che, almeno per un paio di giorni, non dispongo. Quindi devi aspettare pazientemente.

Nel frattempo sarebbe utile se confermassi che tu hai gia' un archivio che arriva alle penultime estrazioni, per cui invece di andare all'indietro a oltranza o fino a una data preimpostata basterebbe andare fino all'ultima data presente sul tuo archivio; tenendo presente che con le webquery ogni estrazione puo' richiedere 1-2 sec sarebbe importante non dover andare indietro per molte estrazioni

Inoltre dovresti chiarire la gestione di colonna B; ora e' una conta incrementale, ma andando indietro nelle estrazioni, ha ancora senso?