ripetere lo script ogni tot secondi

Anonimo

Salve a tutti volevo sapere se qualcuno mi può per cortesia

aggiungere a questo script la funzione ripetizione in automatico ogni tot tempo(anche 5 secondi se è possibile)

Anche con l'integrazione a HTML .

Dim objFSO

Dim objFolder

Dim objFile

Dim objExcel

Dim objWorkbook

Dim sNome

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set objFolder = objFSO.GetFolder("C:\Users\Emanuele\Desktop\Dati")

Set objExcel = CreateObject("Excel.Application")

With objExcel

.Visible = 0

.DisplayAlerts = 0

End With

For Each objFile In objFolder.Files

If LCase(Right(objFile.Name, 4)) = ".xls" Then

sNome = Replace(objFile.Name, ".xls", "")

Set objWorkbook = objExcel.Workbooks.Open(objFile.Path)

objWorkbook.SaveAs "C:" & sNome & ".csv", 6

objWorkbook.Saved = True

objWorkbook.Close

Set objWorkbook = Nothing

End If

objExcel.Quit

Set objExcel = Nothing

Set objFile = Nothing

Set objFolder = Nothing

Set objFSO = Nothing

Io purtroppo non so nulla o quasi di programmazione

grazie in anticipo

un saluto Emanuele

Domanda bloccata. Questa domanda è stata eseguita dalla community del supporto tecnico Microsoft. È possibile votare se è utile, ma non è possibile aggiungere commenti o risposte o seguire la domanda.

0 commenti

Risposta accettata dall'autore della domanda

Anonimo

Ciao Norman ,

il sistema funziona l'unica cosa negativa è che mi crea i fogli

fastidioso perchè devo chiuderli a mano sennò non si aggiorna.

Con un titolo l'ha fatto solo una volta

con piu di uno lo da di più.

Se è fattibile senza tribulare ok sennò lascia stare .ù

Io intanto ti ringrazio per la tua disponibilità

e per la tua preparazione .

Grazie.

Emanuele

Ciao Emanuele,

Innanzitutto, non posso replicare questo comportamento indesiderato.

Comunque, non sono sicuro di aver capito: ulteriori fogli vuoti vengono inseriti nella cartella di lavoro con i nomi predefiniti sequenziali Foglio4, Foglio5 ecc?

===

Regards,

Norman

Ciao Emanuele,

Un altra domanda!

Che intervallo di tempo stai usando ed il comportamento sgradevole si manifesta anche con intervalli di tempo più lunghi?

===

Regards,

Norman

Ciao Emanuele,

In attesa di una risposta alle mie due domande di ieri, se la risposta alla domanda penultima dovesse essere affermativa, potresti provare il seguente workaround (accorgimento) eventuale:

Nel modulo ThisWorkbook, al di sotto della dichiarazione:

'=============>>

Option Explicit

incolla la seguente routine aggiuntiva:

'------------>>

Private Sub Workbook_NewSheet(ByVal SH As Object)

On Error Resume Next

With Application

.DisplayAlerts = False

.ScreenUpdating = False

SH.Delete

.DisplayAlerts = False

.ScreenUpdating = False

End With

End Sub

'------------>>

Nel modulo normale che avevi creato, dopo il codice esistente, incolla il seguente codice aggiuntivo:

'=============>>

Public Sub AddSheet()

Dim sStr As String

Dim aStr As String

Dim bStr As String

Dim dStr As String

Dim eStr As String

Dim Res As String

Const cStyle As Long = vbCritical

eStr = vbNewLine & "Non si è creato un nuovo foglio!"

aStr = "Inserisci un nome per il nuovo foglio"

bStr = "Non hai inserito un nome!" & eStr

dStr = "Hai cancellato il nome!" & eStr

sStr = "Errore!" _

& vbNewLine _

& "Un foglio di con questo nome esiste già!" _

& eStr

Res = Application.InputBox( _

Prompt:=aStr, _

Title:="Nuovo Foglio", _

Type:=2)

On Error Resume Next

Select Case Res

Case "False"

MsgBox Prompt:=dStr, Buttons:=cStyle

Case vbNullString

MsgBox Prompt:=bStr, Buttons:=cStyle

Case Else

If Not SheetExists(Res) Then

Call AddNewSheet(Res)

Else

MsgBox Prompt:=sStr, Buttons:=cStyle

End If

End Select

End Sub

'------------>>

Public Function AddNewSheet(sNome As String)

Dim WB As Workbook

Dim SH As Worksheet

Set WB = ThisWorkbook

'On Error Resume Next

Application.EnableEvents = False

With WB.Worksheets

Set SH = WB.Worksheets.Add '(Before:=(.Count))

End With

Application.EnableEvents = True

SH.Name = sNome

'MsgBox Err.Number

End Function

'------------>>

Private Function SheetExists(ShName As String) As Boolean

Dim WB As Workbook

Dim SH As Worksheet

Set WB = ThisWorkbook

On Error Resume Next

Set SH = WB.Worksheets(ShName)

SheetExists = Not SH Is Nothing

Err.Clear

End Function

'<<=============

La procedura di evento, Workbook_NewSheet, cancella immediatamente qualsiasi nuovo foglio che si crea in quella cartella di lavoro.

Ho anche aggiunto la routine AddSheet e due nuove funzioni per permettere che si aggiunga un nuovo foglio programmaticamente. Le nuove funzioni AddNewSheet e SheetExists sono utilizzate dalla routine AddSheet per verificarsi che il foglio di lavoro non esista già, di disattivare e poi riattivare la procedura di evento di cui sopra. La macro AddSheet raccoglie informazioni sul nuovo foglio di lavoro e passa le istruzioni per le due funzioni.

Come indicato in una risposta precedente, ti consiglio vivamente di provare sempre qualsiasi nuovo codice su una copia della cartella di lavoro interessata.

Inizialmente, vorrei suggerire che non riduca il valore della costante cRunIntervalSeconds a meno di 10 secondi.

===

Regards,

Norman

0 commenti

47 risposte aggiuntive

Anonimo

2013-12-02T11:36:01+00:00

il formato foglio che mi serve e nome >>>>vedii allegati
La risposta è stata utile?

0 commenti Nessun commento
Anonimo

2013-12-02T11:32:31+00:00
1. il "MOSTRO" continua a creare fogli>>> vedi allegato
La risposta è stata utile?

0 commenti Nessun commento
Anonimo

2013-12-02T11:28:30+00:00
Buongiorno Norman ,

vedo che la tua mente ha prodotto un nuovo "MOSTRO"per ME.

Ti devo dei ragguagli

La prova database che mi hai inserito non dà errore ma non succede nulla.

cmq
1. C:\Program Files\Amibroker\Forex >>>>>>>>>>>>Percorso database in Amibroker
2. Forex >>>>>>>>>>>>Nome Database
3. Formato per importare .csv in uso >>vedi allegato
La risposta è stata utile?

0 commenti Nessun commento
Anonimo

2013-12-02T06:23:26+00:00

Norman io purtroppo debbo uscire

questa sera o domani ti faccio sapere

intano grazie infinite.

Ciao Emanuele,

Al fine di tentare di fornirti una soluzione che potrebbe essere più vicino a quello di cui hai bisogno, e in attesa di una risposta alle domande sollevate nel secondo post di Andrea, prova come segue:

Cancella tutto il codice del mio secondo posto. Poi, nel modulo ThisWorkbook della cartella di lavoro che contiene i fogli Foglio A, Foglio B e Foglio C, incolla:

'=============>>

Option Explicit

'------------>>

Private Sub Workbook_Open()

Call AggiornaDatabase

End Sub

'------------>>

Private Sub Workbook_BeforeClose(Cancel As Boolean)

Call StopTimer

End Sub

'<<=============

Nel modulo normale che hai creato in precedenza, incolla:

'=============>>

Option Explicit

Public RunWhen As Double

Public Const cRunIntervalSeconds = 60 'intervallo in secondi

Public Const cRunWhat = "AggiornaDatabase" 'il nome della routine da avviare

Dim arrSH As Variant

Dim errStr 'As String

'------------>>

Public Sub AggiornaDatabase()

Dim srcWB As Workbook

Dim destWB As Workbook

Dim srcSH As Worksheet

Dim srcRng As Range

Dim destRng As Range

Dim i As Long

Dim arrHeaders As Variant

Dim myFolder As String

Dim myPath As String

Dim aStr As String

Dim sStr As String

Dim myFilename As String

Const cPath = "C:\Program\Amibroker\Forex" '<<==== Cambia

Const cNome As String = "Database" '<<==== Cambia

Const cSheets As String = "Foglio A,Foglio B,Foglio C" '<<==== Cambia

Const cHeaders As String = "Date, Time, Open, High, Low, Close" '<<==== Cambia

Set srcWB = ThisWorkbook

myFolder = CurDir

myPath = cPath

ChDrive myPath

On Error GoTo ErrHandler

ChDir myPath

On Error Resume Next

If Right(myPath, 1) <> "" Then

myPath = myPath & Application.PathSeparator

End If

arrSH = Split(cSheets, ",")

arrHeaders = Split(cHeaders, ",")

On Error GoTo ErrHandler

If Not (CheckSheets(srcWB, arrSH)) Then

Err.Raise 9

End If

Application.ScreenUpdating = False

Err.Clear

For i = LBound(arrSH) To UBound(arrSH)

Set srcSH = srcWB.Worksheets(arrSH(i))

Set srcRng = srcSH.Range("A1").CurrentRegion

myFilename = myPath _

& cNome _

& srcWB.Worksheets(arrSH(i)).Name

On Error Resume Next

Set destWB = Workbooks.Open(myFilename)

If destWB Is Nothing Then

Set destWB = Workbooks.Add

With destWB

.Worksheets(1).Range("A1") _

.Resize(1, UBound(arrHeaders) + 1) = arrHeaders

.SaveAs Filename:=myFilename, FileFormat:=xlCSV

End With

End If

With destWB.Worksheets(1)

Set destRng = .Range("A" & .Rows.Count).End(xlUp).Offset(1)

End With

srcRng.Copy Destination:=destRng

destWB.Close SaveChanges:=True

Set destWB = Nothing

Next i

Call StartTimer

XIT:

ChDrive myFolder

ChDir myFolder

Application.ScreenUpdating = True

Exit Sub

ErrHandler:

aStr = "Errore: " & Err.Number _

& vbNewLine _

& Err.Description _

& vbNewLine

Select Case Err.Number

Case 9

sStr = aStr _

& vbNewLine _

& "Non si trova i fogli: " _

& vbNewLine _

& errStr _

& vbNewLine _

& "Questa routine si termina"

Case Else

sStr = aStr

End Select

MsgBox Prompt:=sStr, _

Buttons:=vbCritical

Call StopTimer

Resume XIT

End Sub

'------------>>

Public Function CheckSheets(WB As Workbook, Arr As Variant) As Variant

Dim arrProblem() As Variant

Dim SH As Worksheet

Dim i As Long

Dim j As Long

Dim k As Long

Dim sStr As String

On Error Resume Next

For i = LBound(Arr) To UBound(Arr)

Set SH = WB.Worksheets(Arr(i))

If Err.Number <> 0 Then

j = j + 1

ReDim Preserve arrProblem(1 To j)

arrProblem(j) = Arr(i)

Err.Clear

Else

'do nothing

End If

Next i

If j > 0 Then

sStr = arrProblem(1)

For k = 2 To UBound(arrProblem)

sStr = sStr & vbNewLine & arrProblem(j)

Next

errStr = sStr

CheckSheets = False

Else

CheckSheets = True

End If

End Function

'------------>>

Sub StartTimer()

RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds)

Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _

Schedule:=True

End Sub

'------------>>

Public Sub StopTimer()

On Error Resume Next

Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _

Schedule:=False

End Sub

'<<=============

Per provare il codice con i tuoi fogli di lavoro, tuo computer, e i link DDE, da Excel (anziche dai moduli di codice):

Alt-F8

Seleziona AggiornaDatabase

Esegui

Nota Bene

(1) per arrestare il codice in caso di un problema imprevisto che venga eventualmente incontrato durante le tue prove

Alt-F8

Seleziona StopTimer

Esegui

(2) Finché ti sei accertato che il codice funziona come desiderato e atteso, io ti consiglio vivamente di non ridurre il valore della costante

Public Const cRunIntervalSeconds

dal valore corrente di 60 (= 1 minuto).

In questo modo, avrai abbastanza tempo per fermare il codice prima che sia rilanciato di nuovo

(3) In generale, quando si tenta del nuovo codice, è consigliabile agire su una copia della cartella di lavoro e in questo caso si consiglia fortemente di farlo.

(4) Come scritto, la apertura della cartella di lavoro avvierà il codice e la sua chiasura si fermerà il codice.

===

Regards,

Norman
La risposta è stata utile?

0 commenti Nessun commento