Condividi:        

Automazione Aggiornamento Archivio

Vuoi potenziare i tuoi documenti Word? Non sai come si fa una macro in Excel? Devi creare una presentazione in PowerPoint?
Oppure sei passato a OpenOffice e non sei sicuro di come lavorare al meglio?

Moderatori: Anthony47, Flash30005

Automazione Aggiornamento Archivio

Postdi FrankieBue » 24/03/14 09:28

Ciao amici,

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

Immagine
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
EXCEL 2010
FrankieBue
Utente Junior
 
Post: 24
Iscritto il: 20/01/14 12:23

Sponsor
 

Re: Automazione Aggiornamento Archivio

Postdi Anthony47 » 25/03/14 02:23

E' lo stesso argomento di quest' altra discussione: viewtopic.php?f=26&t=101500

Si continua "lì"
Avatar utente
Anthony47
Moderatore
 
Post: 19196
Iscritto il: 21/03/06 16:03
Località: Ivrea


Torna a Applicazioni Office Windows


Topic correlati a "Automazione Aggiornamento Archivio":


Chi c’è in linea

Visitano il forum: Nessuno e 107 ospiti