come proposto il altro thread ad Anthony, spero che Te riesca a seguire quanto descrivo...
Riguardo all' automazione dell' aggiornamento dell' archivio da una data di partenza presente sotto forma di url in:
- Codice: Seleziona tutto
.Navigate "http://data.nowgoal.com/1x2/companyhistory.aspx?id=110&company=SNAI&matchdate=" & [EL2] & "-" & [EL3] & "-" & [EL4]
dove:
EL2 = ANNO EL3 = MESE EL4 = GIORNO
http://i62.tinypic.com/2ll1ssw.jpg
Senza stare a ripetere sempre manualmente
- Codice: Seleziona tutto
Sub Aggiorna_Archivio()
'
' Aggiorna_Archivio Macro
'
Call Importa_Dati
Call Copia_In_Archivio
'
End Sub
con il cambio data e l'esecuzione di queste seguenti macro
- Codice: Seleziona tutto
Sub Importa_Dati()
Dim mIE As Object
Dim mTables, mTable
Dim mRows, mRow
Dim mCells, mCell
Dim mRiga As Long, mColonna As Long
Dim k1 As Integer, n As Integer
On Error GoTo Errori
Application.ScreenUpdating = False
Worksheets("ToBet").Select
Call clear_results
Call Righe_Dispari_L
Call Righe_Pari_L
'controlli
n = 1 ' tbl da importare se presente
mRiga = 8 'inizio scrittura tabella
k1 = 0
Set mIE = CreateObject("InternetExplorer.Application")
With mIE
.AddressBar = False
.StatusBar = False
.MenuBar = False
.Toolbar = 0
.Visible = False
.Navigate "http://data.nowgoal.com/1x2/companyhistory.aspx?id=110&company=SNAI&matchdate=" & [EL2] & "-" & [EL3] & "-" & [EL4]
End With
While mIE.Busy Or mIE.READYSTATE <> 4
DoEvents
Wend
Set mTables = mIE.document.all.tags("TABLE")
With mTables
For Each mTable In mTables
k1 = k1 + 1
With Range(Cells(mRiga - 2, 1), Cells(mRiga - 2, 1))
.Value = "Table: " & k1
.Interior.ColorIndex = 37
.Font.Bold = True
End With
If Range("D3") <> "" Then k1 = n
Set mRows = mTable.Rows
For Each mRow In mRows
Set mCells = mRow.Cells
nCol = mCells.Length
If PreNCol > nCol Then
mColonna = PreNCol - nCol - 1
Else
mColonna = 1
End If
For Each mCell In mCells
ActiveSheet.Cells(mRiga, mColonna) = mCell.innerText
mColonna = mColonna + 1
Next mCell
PreNCol = nCol
mRiga = mRiga + 1
Next mRow
If n <> 0 And k1 = n Then GoTo Uscita
mRiga = mRiga + 3
Next mTable
End With
Sheets("ToBet").Select
Range("BU2").Select
Uscita:
Set mCell = Nothing
Set mCells = Nothing
Set mRow = Nothing
Set mRows = Nothing
Set mTable = Nothing
Set mTables = Nothing
mIE.Quit
Set mIE = Nothing
Exit Sub
Errori:
MsgBox Err.Number & "-" & Err.Description
Resume Uscita
Columns("B:B").Select
Selection.ColumnWidth = 10.67
Selection.ColumnWidth = 12.67
Selection.ColumnWidth = 16
Columns("K:K").Select
Selection.ColumnWidth = 17.44
Selection.ColumnWidth = 21.56
Range("A6").Select
End Sub
Sub Copia_In_Archivio()
Application.ScreenUpdating = False
Sheets("ToBet").Select
Range("BU2:EJ" & [EP1]).Copy
Sheets("Archivio").Select
'posiziona prima cella libera
With Worksheets("Archivio")
Dim lRiga As Long
lRiga = .Range("C" & Rows.Count).End(xlUp).Row
.Cells(lRiga + 1, 1).Select
End With
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("ToBet").Select
Range("EO1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = ""
Range("EO1").Select
Sheets("ToBet").Select
Range("BU2").Select
End Sub
E' possibile che io riempia l' archivio automaticamnete lasciando lavorare il foglio di lavoro senza che io c metta mano durante il processo e non debba stare a cambiare date ed eseguire sistematicamente il tutto mediante pulsanti ???
grazie della fattiva collaborazione,
buona giornata.
rilascio il file : NowGoal Snai.xlsm
