Moderatori: Anthony47, Flash30005
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
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
#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
#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
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.Si' certo Anthony47 : ho fatto entrambi i controlli incrociati.
In genere dico "penultimo adattamento", e infatti ho fatto male a scrivere "ultimo adattamento". Infatti, avendo fatto 30 tanto vale fare 31...Anthony ha scritto:Faccio volentieri un ultimo adattamento per andare dietro al diverso formato dati del tuo fornitore
#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
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 richiestaEsiste questo inconveniente : per inserire l' estrazione, ho necessita' di scrivere la data.
Puoi superare questo ostacolo, cioe' aggiornare senza l' inserimento manuale della data ?
Si puo' fare qualcosa sfruttando una strana caratteristica del sito che puo' aiutare. Ad esempio andare all'indietro fino a una data preimpostataChiedo inoltre che questa macro, senza l' uso della digitazione della macro, possa aggiornare "n" estrazioni a ritroso, indipendentemente da quelle assenti.
Torna a Applicazioni Office Windows
Macro modifica date scelta periodo Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 11 |
Inserire dati filtrati da 2 file ad un terzo file Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 14 |
Supporto per sviluppo macro VBA Ordinare per data Autore: Carletto Ribolla |
Forum: Applicazioni Office Windows Risposte: 3 |
Eliminare righe diverse dalla prima data del mese Autore: dipdip |
Forum: Applicazioni Office Windows Risposte: 4 |
Visitano il forum: Nessuno e 9 ospiti