Nuovo script

[Antonio Pagano]

Sembra che vada adesso con il nuovo txt che hai messo mi dice nessuna nuova estrazione da aggiungere ma strano che quella di ieri sera non sia ancora disponibile.

Ciao Ken allora non mi sbagliavo, infatti sto cercando di avere a video l'ultima estrazione.

 

[Baciccia4251]

Ciao Ken allora non mi sbagliavo, infatti sto cercando di avere a video l'ultima estrazione.

Acc. Al l'Alzheimer non ho scaricato l'ultimo file, mi sono dimenticato che c'era stata una nuova estrazione Sabato.
Riscaricate al link segnato nell'altro post
Per vedere nel file txt qual è l'ultima estrazione basta aprirlo e scorrere
Acc. FC
Bacicciuk

 

[Baciccia4251]

Baciccia sei simpaticissimo, grazie. Esequendo la macro di aggiorna archivio mi dà errore a : Me.TextBox1.Value = ultimaData.
Io la ho incollata qui dimmi se è nel poto giusto.
Sub AggiornaArchivioLocale()
Dim wsArchivio As Worksheet, wsAppoggio As Worksheet
Dim lastRowArchivio As Long
Dim currentRow As Long, startRow As Long
Dim i As Long
Dim numeri(4) As Integer
Dim ultimaDataArchivio As Date
Dim fso As Object, ts As Object
Dim fileContent As String, arrLines() As String
Dim dataEstrazione As Date
Dim currentDate As Date
Dim ruota As String
Dim continueProcessing As Boolean

' Disabilita aggiornamento schermo e calcoli automatici per migliorare la velocità
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

' 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
ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count)).name = "Appoggio"
Set wsAppoggio = ThisWorkbook.Sheets("Appoggio")
End If
On Error GoTo 0

' Ottieni l'ultima data dall'archivio, assume che la data sia nella colonna C
lastRowArchivio = wsArchivio.Cells(wsArchivio.Rows.count, 3).End(xlUp).row
If lastRowArchivio > 1 Then
ultimaDataArchivio = wsArchivio.Cells(lastRowArchivio, 3).Value
End If

' Leggi il file di testo locale
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fspenTextFile(ThisWorkbook.Path & "\storico_locale.txt", 1)
If Err.Number <> 0 Then
MsgBox "File di testo locale non trovato. Assicurati che il file 'storico_locale.txt' si trovi nella stessa cartella del file Excel.", vbCritical
GoTo CleanUp
End If
On Error GoTo 0

fileContent = ts.ReadAll
ts.Close

' Dividi il contenuto in righe
fileContent = Replace(fileContent, vbCrLf, vbLf)
arrLines = Split(fileContent, vbLf)

' Inizializza variabili
currentRow = 0
continueProcessing = True
currentDate = 0

' Pulisci il foglio Appoggio
wsAppoggio.Cells.Clear

' Processa le righe dal basso verso l'alto
For i = UBound(arrLines) To 0 Step -1
If Trim(arrLines(i)) <> "" Then
' Estrai la data e converti in formato data
dataEstrazione = DateSerial(left(arrLines(i), 4), Mid(arrLines(i), 6, 2), right(left(arrLines(i), 10), 2))

' Controlla se abbiamo raggiunto l'ultima data dell'archivio
If dataEstrazione <= ultimaDataArchivio Then
continueProcessing = False
Exit For
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 = 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 come valori numerici
For j = 0 To 4
numeri(j) = val(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
Next i

' Ordina il foglio Appoggio per data crescente
If currentRow > 0 Then
With wsAppoggio.Sort
.SortFields.Clear
.SortFields.Add key:=wsAppoggio.Range("C1:C" & currentRow), Order:=xlAscending
.SetRange wsAppoggio.Range("C1:BF" & currentRow)
.Header = xlNo
.Apply
End With

' Copia in Archivio e aggiunge numerazione progressiva
lastRowArchivio = wsArchivio.Cells(wsArchivio.Rows.count, 3).End(xlUp).row
wsAppoggio.Range("C1:BF" & currentRow).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
lastValue = wsArchivio.Cells(wsArchivio.Rows.count, 1).End(xlUp).Value

' Aggiungi i numeri progressivi nella colonna A
startRow = lastRowArchivio + 1
For i = 1 To currentRow
wsArchivio.Cells(startRow + i - 1, 1).Value = lastValue + i
Next i
End If

CleanUp:
' Ripristina impostazioni
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

If currentRow > 0 Then
MsgBox "Aggiornamento completato. Aggiunte " & currentRow & " nuove estrazioni."
Else
MsgBox "Nessuna nuova estrazione da aggiungere."
End If

End Sub


Sub LeggiUltimaData()
Dim filePath As String
Dim ultimaRiga As String
Dim ultimaData As String

' Apri la finestra di dialogo per selezionare il file
filePath = Application.GetOpenFilename("File di testo (*.txt), *.txt")

' Verifica che un file sia stato selezionato
If filePath = "False" Then
MsgBox "Nessun file selezionato", vbExclamation
Exit Sub
End If

' Apri il file e leggi l'ultima riga
Open filePath For Input As #1
Do While Not EOF(1)
Line Input #1, ultimaRiga
Loop
Close #1

' Estrai la data dalla prima parte della riga (prima del tab)
ultimaData = left(ultimaRiga, 10)

' Assumendo che tu abbia già una TextBox chiamata TextBox1
Me.TextBox1.Value = ultimaData
End Sub

No. La Macro era solo un esempio, eventualmente da adattare.
Però non l'avevo provata perché, ora ricordo, volevo chiederti qual era la data che desideravi, se l'ultima nel file txt, o se preferivi l'ultima estrazione in archivio.
Quest'ultima, nella prossima versione che posterò ci sarà.
Quindi basta un po' di pazienza.
Anche perché se vuoi vedere l'ultima data nel file txt (prima devi estrarre il contenuto scaricato e POI rinominare il file txt estratto col nome che ti ho detto) è sufficiente cliccare 2 volte sul file e scorrere.
Chiaroscuro?

 

[Antonio Pagano]

Ok aspetto aspetto Baciccia ver. 9.Basta ora guardo la partita grazie e buona serata.

 

[Baciccia4251]

13.21 MB file on MEGA

mega.nz

Nel foglio Ken in alto appare la data dell'ultima estrazione in archivio. Aggiorna archivio Ken ora funziona così, seguite con attenzione per evitare quiquoqua:

1) Create una cartella dove ci sia solo il file Excel
2) In questa cartella scaricate il file zip ed estraetene il contenuto SENZA RINOMINARLO (deve essere l'unico TXT nella cartella)
3) lanciate "AggiornaArchivioKen" e, se non avete fatto cappelletti aggiornerà l'archivio (pensa la macro a rinominare il file)

Il tutto l'ho testato e funziona.
Che Budda vi sostenga, Visnù vi aiuti e la sfiga non vi perseguiti
Baciccin che ama il bon vin

 

[Baciccia4251]

Wuaoo ! il ric trivellato fa a caso mio ma ce tanto di più molto bello e completo che può aiutare a sceglire .
Ci ho messo un pò non riuscivo a sbloccare la macro ora va grazie Baciccia .

 

[KEN]

Al momento non si è aggiornato , domani riprovo.