Buongiorno GioRyuKen72, è tuttto giusto.
Ho visto però che nel lavoro che hai mandato mancano le macro per poter aggiornare l'archivio e anche il tuo foglio previsionistico.
La macro è questa:
----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Sub AggiornaArchivio()
If Not ControllaRiferimenti() Then Exit Sub
' Verifica 7-Zip
Dim zipPath As String
zipPath = Get7ZipPath()
If zipPath = "" Then
MsgBox "7-Zip non trovato. Installare 7-Zip.", vbCritical
Exit Sub
End If
' Verifica permessi cartella
If Not TestWritePermissions(ThisWorkbook.Path) Then
MsgBox "Permessi insufficienti sulla cartella. Verificare i diritti di scrittura.", vbCritical
Exit Sub
End If
On Error GoTo ErrorHandler
Dim url As String, zipFile As String, txtFile As String
Dim wsArchivio As Worksheet, wsAppoggio As Worksheet
Dim lastRow As Long, lastRowArchivio As Long
Dim i As Long, j As Long
Dim http As Object, stream As Object, WshShell As Object
Dim fileContent As String, arrLines() As String
Dim dataEstrazione As String, ruota As String
Dim numeri(4) As String
Dim ultimaDataArchivio As Date
Dim currentRow As Long
Dim rngAppoggio As Range
Dim continueProcessing As Boolean
Dim currentDate As String
' Disabilita aggiornamenti schermo
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
' Imposta l'URL del file zip
url = "
https://www.igt.it/STORICO_ESTRAZIONI_LOTTO/storico01-oggi.zip"
' Imposta i nomi dei file temporanei
zipFile = GetTempFilePath(".zip")
txtFile = GetTempFilePath(".txt")
' Pulisci i file temporanei se esistono
On Error Resume Next
If Dir(zipFile) <> "" Then Kill zipFile
If Dir(txtFile) <> "" Then Kill txtFile
On Error GoTo ErrorHandler
' Imposta i fogli di lavoro
Set wsArchivio = ThisWorkbook.Sheets("Archivio")
' Controlla se esiste il foglio Appoggio, se non esiste lo crea
On Error Resume Next
Set wsAppoggio = ThisWorkbook.Sheets("Appoggio")
If wsAppoggio Is Nothing Then
Set wsAppoggio = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count))
wsAppoggio.name = "Appoggio"
End If
On Error GoTo ErrorHandler
' Ottieni l'ultima data dall'archivio
lastRowArchivio = wsArchivio.Range("C" & Rows.count).End(xlUp).row
If lastRowArchivio > 1 Then
ultimaDataArchivio = wsArchivio.Cells(lastRowArchivio, 3).Value
End If
' Download del file zip usando late binding
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", url, False
http.Send
If http.Status <> 200 Then
MsgBox "Errore nel download del file. Status: " & http.Status
GoTo CleanUp
End If
' Salva il file zip
Set stream = CreateObject("ADODB.Stream")
With stream
.Type = 1 'adTypeBinary
.Open
.Write http.responseBody
.SaveToFile zipFile, 2 'adSaveCreateOverWrite
.Close
End With
' Estrai il file zip
Set WshShell = CreateObject("WScript.Shell")
' Crea una cartella temporanea per l'estrazione
Dim extractPath As String
extractPath = ThisWorkbook.Path & "\temp_extract_" & Format(Now, "yyyymmddhhnnss")
MkDir extractPath
' Estrai nella cartella temporanea
WshShell.Run """" & zipPath & """ e """ & zipFile & """ -o""" & extractPath & """ -y", 0, True
' Attendi un momento per assicurarsi che il file sia estratto
Application.Wait Now + TimeValue("00:00:02")
' Cerca qualsiasi file .txt nella cartella di estrazione
Dim extractedFile As String
extractedFile = Dir(extractPath & "\*.txt")
If extractedFile = "" Then
MsgBox "File txt non trovato dopo l'estrazione. Verificare il contenuto del file ZIP."
' Pulisci la cartella temporanea
On Error Resume Next
Kill extractPath & "\*.*"
RmDir extractPath
On Error GoTo ErrorHandler
GoTo CleanUp
End If
' Copia il file nella posizione finale
FileCopy extractPath & "\" & extractedFile, txtFile
' Pulisci la cartella temporanea
On Error Resume Next
Kill extractPath & "\*.*"
RmDir extractPath
On Error GoTo ErrorHandler
' Verifica che il file txt esista nella posizione finale
If Dir(txtFile) = "" Then
MsgBox "Errore nella copia del file estratto"
GoTo CleanUp
End If
' Pulisci il foglio Appoggio
wsAppoggio.Cells.Clear
' Leggi il file txt
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
With fs
penTextFile(txtFile)
fileContent = .ReadAll
.Close
End With
' Dividi il contenuto in righe
fileContent = Replace(fileContent, vbCrLf, vbLf)
arrLines = Split(fileContent, vbLf)
' Inizializza variabili
currentRow = 0
continueProcessing = True
currentDate = ""
' Processa le righe dal basso verso l'alto
i = UBound(arrLines)
Do While i >= 0 And continueProcessing
If Trim(arrLines(i)) <> "" Then
' Estrai la data
dataEstrazione = Format(DateSerial(left(arrLines(i), 4), _
Mid(arrLines(i), 6, 2), _
right(left(arrLines(i), 10), 2)), _
"dd/mm/yyyy")
' Controlla se abbiamo raggiunto l'ultima data dell'archivio
If CDate(dataEstrazione) <= ultimaDataArchivio Then
continueProcessing = False
Exit Do
End If
' Se è una nuova data, crea una nuova riga
If currentDate <> dataEstrazione Then
currentRow = currentRow + 1
currentDate = dataEstrazione
wsAppoggio.Cells(currentRow, 3).NumberFormat = "dd/mm/yyyy"
wsAppoggio.Cells(currentRow, 3).Value = CDate(dataEstrazione)
End If
' Estrai ruota e numeri
Dim parts() As String
parts = Split(Mid(arrLines(i), 12), vbTab)
ruota = parts(0)
' Copia i numeri nell'array convertendoli in valori numerici
For j = 0 To 4
numeri(j) = CLng(parts(j + 1))
Next j
' Posiziona i numeri in base alla ruota
Select Case ruota
Case "BA"
wsAppoggio.Cells(currentRow, 4).Resize(1, 5).Value = numeri
Case "CA"
wsAppoggio.Cells(currentRow, 9).Resize(1, 5).Value = numeri
Case "FI"
wsAppoggio.Cells(currentRow, 14).Resize(1, 5).Value = numeri
Case "GE"
wsAppoggio.Cells(currentRow, 19).Resize(1, 5).Value = numeri
Case "MI"
wsAppoggio.Cells(currentRow, 24).Resize(1, 5).Value = numeri
Case "NA"
wsAppoggio.Cells(currentRow, 29).Resize(1, 5).Value = numeri
Case "PA"
wsAppoggio.Cells(currentRow, 34).Resize(1, 5).Value = numeri
Case "RM"
wsAppoggio.Cells(currentRow, 39).Resize(1, 5).Value = numeri
Case "TO"
wsAppoggio.Cells(currentRow, 44).Resize(1, 5).Value = numeri
Case "VE"
wsAppoggio.Cells(currentRow, 49).Resize(1, 5).Value = numeri
Case "RN" ' Ruota Nazionale
wsAppoggio.Cells(currentRow, 54).Resize(1, 5).Value = numeri
End Select
End If
i = i - 1
Loop
' Ordina il foglio Appoggio per data crescente
If currentRow > 0 Then
Set rngAppoggio = wsAppoggio.Range("C1:BF" & currentRow)
With wsAppoggio.Sort
.SortFields.Clear
.SortFields.Add key:=wsAppoggio.Range("C1"), Order:=xlAscending
.SetRange rngAppoggio
.Header = xlNo
.Apply
End With
' Copia in Archivio e aggiunge numerazione progressiva
lastRowArchivio = wsArchivio.Range("C" & Rows.count).End(xlUp).row
rngAppoggio.Copy
wsArchivio.Cells(lastRowArchivio + 1, 3).PasteSpecial xlPasteValuesAndNumberFormats
' Converti i numeri da testo a valore
Dim rngNew As Range
Set rngNew = wsArchivio.Range(wsArchivio.Cells(lastRowArchivio + 1, 4), _
wsArchivio.Cells(lastRowArchivio + currentRow, wsArchivio.Columns.count))
rngNew.Value = rngNew.Value
' Ottieni l'ultimo valore nella colonna A
Dim lastValue As Long
Dim newRowCount As Long
Dim startRow As Long
lastValue = wsArchivio.Range("A" & wsArchivio.Range("A" & Rows.count).End(xlUp).row).Value
startRow = lastRowArchivio + 1
newRowCount = currentRow
' Aggiungi i numeri progressivi nella colonna A
For i = 1 To newRowCount
wsArchivio.Cells(startRow + i - 1, 1).Value = lastValue + i
Next i
End If
CleanUp:
' Pulizia
On Error Resume Next
If Dir(zipFile) <> "" Then Kill zipFile
If Dir(txtFile) <> "" Then Kill txtFile
If Dir(extractPath & "\*.*") <> "" Then
Kill extractPath & "\*.*"
RmDir extractPath
End If
' Ripristina le impostazioni di Excel
With Application
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.CutCopyMode = False
End With
If currentRow > 0 Then
MsgBox "Aggiornamento completato. Aggiunte " & currentRow & " nuove estrazioni."
Application.Run "VerificaNumeriUguali"
Else
MsgBox "Nessuna nuova estrazione da aggiungere."
End If
Exit Sub
ErrorHandler:
MsgBox "Si è verificato un errore: " & Err.Description & vbCrLf & _
"Numero errore: " & Err.Number & vbCrLf & _
"Riga: " & Erl
Resume CleanUp
End Sub
-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
però nel file postato la macro è già presente, per i fogli previsionistici non c'è macro (ci sono fogli nascosti e filtri)
Pico della Mirandola
