Ok Flash....ci siamo quasi...
Pensa che mi dava errore....2 volte e tutte e 2 le volte son riuscito (incredibile) a cavarmela da solo...
la prima volta mi dava errore in queste righe:
UR4 = Ws4.Range("A" & Rows.Count).End(xlUp).Row '<<<< calcolo le righe nel foglio "Appoggio2"
URC = Ws4.Range("IV1").End(xlToLeft).Column '<<<< calcolo le colonne nel foglio "Appoggio2"
URS = Ws1.Range("A" & Rows.Count).End(xlUp).Row '<<<< calcolo le righe nel foglio "Archivio1939" mi diceva che nessun oggetto era specificato...
e ho fatto il tentativo di copiare questo:
Set Ws1 = Worksheets("Archivio1939") '<<< setto i vari fogli evitando di ripetere worksheet("nomefoglio")
Set Ws3 = Worksheets("Appoggio")
Set Ws4 = Worksheets("Appoggio2")dopo i Vettori...e prima della riga del Debug...
e mi è andata bene...ho ragionato che essendo un'altra macro dovevo settare anche lì i worksheet...
poi....mi ha dato un problema inerente alla grandezza delle colonne...
allora ho settato tutte e 7 le colonne dell'archivio storico a 8 di larghezza...
e finalmente è riuscito nell'aggiornamento totale...
però c'è un problema...
Se Nascondo "Appoggio" e "Appoggio2" ...
se premo il tasto per aggiornare mi dà questo problema:
Errore di run-time '1004'
Errore nel metodo Select per la classe Worksheete mi rimanda a questa riga il Debug...
Ws3.Select '<<<<<<<<<<< da qui in poi è un classico codice QueryWeb registrato su un sito noto e scrive su Foglio "Appoggio"c'è da dire che io li vorrei nascosti i fogli "Appoggio" e "Appoggio2" ...
si può fare qualcosa anche per questo ????
intanto ti posto il codice come ce l'ho ora nel VBA...
- Codice: Seleziona tutto
Sub CreaArchDaWeb()
Application.ScreenUpdating = False
Application.Calculation = xlManual
AnnoA = 1939 '<<<<assegno il primo anno ufficiale lotto
Set Ws1 = Worksheets("Archivio1939") '<<< setto i vari fogli evitando di ripetere worksheet("nomefoglio")
Set Ws3 = Worksheets("Appoggio")
Set Ws4 = Worksheets("Appoggio2")
URS = Ws1.Range("A" & Rows.Count).End(xlUp).Row '<<<<<conto le righe nel ws1
If Ws1.Range("A" & URS).Value <> "" Then AnnoA = Year(Ws1.Range("A" & URS).Value) '<<< controllo l'anno dell'archivio
For annoweb = AnnoA To Year(Now) '<<< ciclo dall'anno archivio all'anno attuale
Ws3.Select '<<<<<<<<<<< da qui in poi è un classico codice QueryWeb registrato su un sito noto e scrive su Foglio "Appoggio"
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://www.lottoconsult.it/estrazioni_lotto.asp?anno=" & annoweb, Destination:=Range("A1"))
.Name = "estrazioni_lotto.asp?anno=" & annoweb
.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 = "7,8"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Rows("1:2").Select
Selection.Delete Shift:=xlUp
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
UR3 = Ws3.Range("A" & Rows.Count).End(xlUp).Row
UR4 = Ws4.Range("A" & Rows.Count).End(xlUp).Row
For Cdata = 1 To UR3 '<<<< questo ciclo standardizza la data nel foglio "Appoggio"
Range("A" & Cdata).Value = Format(Mid(Range("A" & Cdata).Value, 6, 15), "MM/DD/yyyy")
Next Cdata
If annoweb < 2005 Then '<<<< nel 2005 è subentrata la Ruota Nazionale pertanto inserisce 5 colonne se l'anno è minore di 2005
Columns("B:B").Select
For AggC = 1 To 5
Selection.Insert Shift:=xlToRight
Next AggC
End If
Columns("B:BD").Select '<<<< seleziono le colonne e regolo la larghezza per contenere due numeri
Selection.ColumnWidth = 2.54
Ws3.Range("A1:BD" & UR3).Select
Selection.Copy '<<<< copio il range in "Appoggio" e incollo in "Appoggio2"
Ws4.Select
X = 1
If UR4 = 1 Then X = 0
Range("A" & UR4 + X).Select
ActiveSheet.Paste
Ws3.Select
Range("A1:BD" & UR3).Clear
Range("A1").Select
Next annoweb '<<<< anno successivo deterinato dal ciclo
Ws4.Select
Call Incolonna '<<<< chiama la macro Incolonna, vedi descrizione azioni riportate
Range("A1").Select
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub Incolonna()
Dim Vettore(11) As String 'dichiaro 11 vettori (le 11 ruote)
Vettore(1) = "RN"
Vettore(2) = "BA"
Vettore(3) = "CA"
Vettore(4) = "FI"
Vettore(5) = "GE"
Vettore(6) = "MI"
Vettore(7) = "NA"
Vettore(8) = "PA"
Vettore(9) = "RM"
Vettore(10) = "TO"
Vettore(11) = "VE"
Set Ws1 = Worksheets("Archivio1939") '<<< setto i vari fogli evitando di ripetere worksheet("nomefoglio")
Set Ws3 = Worksheets("Appoggio")
Set Ws4 = Worksheets("Appoggio2")
UR4 = Ws4.Range("A" & Rows.Count).End(xlUp).Row '<<<< calcolo le righe nel foglio "Appoggio2"
URC = Ws4.Range("IV1").End(xlToLeft).Column '<<<< calcolo le colonne nel foglio "Appoggio2"
URS = Ws1.Range("A" & Rows.Count).End(xlUp).Row '<<<< calcolo le righe nel foglio "Archivio1939"
'cancella estrazioni doppie
For CD = URS - 1 To 2 Step -1
UR4 = Ws4.Range("A" & Rows.Count).End(xlUp).Row
Data1 = Ws1.Range("A" & CD).Value
For CD2 = UR4 To 1 Step -1 '<<<<< mancava lo Step-1 qui
If Ws4.Range("A" & CD2).Value = Data1 Then
Ws4.Rows(CD2 & ":" & CD2).Delete Shift:=xlUp
GoTo salta
End If
Next CD2
salta:
Next CD
'----
'<<< da qui in poi adatto quanto scaricato dal web al formato che mi occorre (web una riga per estrazione, archivio una riga per estrazione e per ruota)
For IncR = 1 To UR4
For IncC = 2 To URC Step 5
ColS = 2
DaTaE = Ws4.Cells(IncR, 1).Value
If DaTaE = "" Then
GoTo Esci
End If
Ruota = Int((IncC - 2) / 5) + 1
RU = Vettore(Ruota)
Ws1.Cells(URS + 1 + (IncR - 1) * 11 + Ruota, 1).Value = DaTaE
Ws1.Cells(URS + 1 + (IncR - 1) * 11 + Ruota, 2).Value = RU
For Cr = 1 To 5
Ws1.Cells(URS + 1 + (IncR - 1) * 11 + Ruota, ColS + Cr).Value = Ws4.Cells(IncR, IncC + Cr - 1).Value
Next Cr
Next IncC
Next IncR
'<<<<< fine conversione archivi
'qui ordino l'archivio (foglio "Archivio1939" per data e ruota)
Ws1.Select
URS = Ws1.Range("A" & Rows.Count).End(xlUp).Row
Columns("A:G").Select
Application.CutCopyMode = False
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B1") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
:=xlSortNormal
'cancella estrazioni mancanti (nel caso si verificassero celle vuote)
For S = URS To 1 Step -1
If Range("C" & S) = "" Then Rows(S & ":" & S).Delete Shift:=xlUp
Next S
Esci:
End Sub
che ne pensi ??? Dai per essere alle prime armi....le 2 volte che me la son cavata da solo coi problemi in questa macro....non son stato poi così male eh...