Ciao Daniel,
Per avviare la routine ogni ora, cancella tutto il codice precedente nel modulo del foglio, nel modulo ThisWorkbook e anche nel modulo standard.
Poi, nel modulo ThisWorkbook, incolla:
'=========>>
Option Explicit
'--------->>
Private Sub Workbook_Open()
Call StartTimer
End Sub
'--------->>
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call StopTimer
End Sub
'<<=========
Nel modulo standard, incolla il seguente codice:
'=========>>
Option Explicit
Public RunWhen As Double
Public Const cRunIntervalHours = 1 '\ Un'ora
Public Const cRunWhat = "mySpreads"
'--------->>
Public Sub StartTimer()
RunWhen = Now + TimeSerial(cRunIntervalHours, 0, 0)
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
'--------->>
Public Sub MySpreads()
Dim WB As Workbook
Dim SH As Worksheet, destSH As Worksheet
Dim oDic As Object, oDic2 As Object
Dim Rng As Range, destRng As Range
Dim rCell As Range
Dim arrParentKeys As Variant, arrParentItems As Variant
Dim arrChildKeys As Variant, arrChildItems As Variant
Dim arrHeaders As Variant, arrOut() As Variant
Dim i As Long, j As Long, k As Long
Dim p As Long, q As Long, r As Long
Dim iLastRow As Long, jLastRow As Long
Dim dDate As Date, dTime As Date
Const sIntestazioni As String = _
"ID,Titolo-1,Quote,Titolo-2,Quote,Spread,Data,Ora" '<<==== Modifica
Const mioParametro As Double = 10 '<<==== Modifica
Const sReportShName As String = "Report" '<<==== Modifica
Const sCopyFileName As String = "C:\MyAlarms\Alarm.xls" '<<==== Modifica
On Error GoTo ErrHandler
Application.ScreenUpdating = False
dDate = Format(Date, "dd/mm/yy")
dTime = Format(Time, "hh:mm:ss")
Set WB = ThisWorkbook
With WB
Set SH = .Sheets("Foglio1")
'<<==== Modifica
On Error Resume Next
Set destSH = .Sheets(sReportShName)
If Err.Number = 9 Then
arrHeaders = Split(sIntestazioni, ",")
Set destSH = .Sheets.Add(after:=SH)
With destSH
.Name = sReportShName
With .Range("A1").Resize(1, UBound(arrHeaders) + 1)
.Value = arrHeaders
With .Font
.Size = 12
.Bold = True
.Underline = True
End With
End With
End With
End If
Err.Clear
End With
On Error GoTo ErrHandler
With SH
iLastRow = LastRow(SH, .Columns("A:A"))
Set Rng = .Range("A2:C" & iLastRow)
End With
With destSH
jLastRow = LastRow(destSH, .Columns("A:A"))
Set destRng = .Range("A" & jLastRow + 1 - (jLastRow <> 1))
End With
Set oDic = CreateObject("Scripting.Dictionary")
oDic.CompareMode = vbTextCompare
For i = 1 To Rng.Rows.Count
With Rng.Cells(i, 2)
If oDic.Exists(.Value) Then
Set oDic2 = oDic.Item(.Value)
If Not oDic2.Exists(.Value) Then
oDic2.Add Key:=.Offset(0, -1), Item:=.Offset(0, 1)
End If
Else
Set oDic2 = CreateObject("Scripting.Dictionary")
oDic2.CompareMode = vbTextCompare
oDic2.Add Key:=.Offset(0, -1), Item:=.Offset(0, 1)
oDic.Add Key:=.Value, Item:=oDic2
End If
End With
Next i
arrParentKeys = oDic.Keys
For i = 0 To UBound(arrParentKeys)
Set oDic2 = oDic.Item(arrParentKeys(i))
arrChildKeys = oDic2.Keys
arrChildItems = oDic2.Items
k = oDic2.Count
For j = 0 To k - 1
For p = j + 1 To k - 1
If Abs(arrChildItems(j) - arrChildItems(p)) > mioParametro Then
q = q + 1
ReDim Preserve arrOut(1 To 8, 1 To q)
arrOut(1, q) = arrParentKeys(i)
arrOut(2, q) = arrChildKeys(j)
arrOut(3, q) = arrChildItems(j)
arrOut(4, q) = arrChildKeys(p)
arrOut(5, q) = arrChildItems(p)
arrOut(6, q) = arrChildItems(j) - arrChildItems(p)
arrOut(7, q) = dDate
arrOut(8, q) = dTime
End If
Next p
Next j
Next i
If Not CBool(q) Then
GoTo XIT
End If
With destRng.Resize(q, UBound(arrOut, 1))
.Value = Application.Transpose(arrOut)
.EntireColumn.AutoFit
For r = 1 To .Columns.Count Step 2
With destSH.UsedRange
.Columns(r).Interior.ColorIndex = 9
.Columns(r + 1).Interior.ColorIndex = 6
.Columns(6).Font.ColorIndex = 3
End With
Next r
End With
destSH.Copy
With Application
.DisplayAlerts = False
With ActiveWorkbook
.SaveAs Filename:=sCopyFileName, FileFormat:=OpenXMLWorkbook
.Close
End With
.DisplayAlerts = True
End With
Call InformaDaniel(q, dTime, dDate, sCopyFileName)
Call StartTimer
DoEvents
XIT:
Set oDic2 = Nothing
Set oDic = Nothing
Application.ScreenUpdating = True
On Error GoTo 0
Exit Sub
ErrHandler:
Call MsgBox(Prompt:="Error " _
& Err.Number _
& " (" _
& Err.Description _
& ") nella routine: Tester", _
Buttons:=vbCritical, _
Title:="ERRORE")
Err.Clear
Resume XIT
End Sub
'--------->>
Public Sub InformaDaniel(AlarmNum As Long, _
AlarmTime As Date, _
AlarmDate As Date, _
AlarmFile As String)
Dim oApp As Object
Dim oMail As Object
Dim sBody As String
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)
sBody = "Ciao Daniel," _
& vbNewLine & vbNewLine _
& "Alle " & AlarmTime & Space(1) _
& Format(AlarmDate, "ddd dd/mm/yyyy") _
& vbNewLine & _
"Ci sono stato verificato " & AlarmNum _
& " coppie di titoli" _
& vbNewLine & _
"in cui lo spread e' stato in eccesso del valore previsto" _
& vbNewLine & _
"Vedi il file allegato per i dettagli."
On Error Resume Next
With oMail
.To = "******@outlook.com"
.CC = ""
.BCC = ""
.Subject = "SPREAD WARNING!"
.Body = sBody
.Attachments.Add (AlarmFile)
.Send
End With
On Error GoTo 0
Set oMail = Nothing
Set oApp = Nothing
End Sub
'--------->>
Public Function LastRow(SH As Worksheet, _
Optional Rng As Range)
If Rng Is Nothing Then
Set Rng = SH.Cells
End If
On Error Resume Next
LastRow = Rng.Find(What:="*", _
after:=Rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
'<<=========
Salva, chiudi e riapri il file.
===
Regards,
Norman
![](data:image/svg+xml, %3Csvg xmlns='http://www.w3.org/2000/svg' height='64' class='font-weight-bold' style='font: 600 30.11764705882353px "SegoeUI", Arial' width='64'%3E%3Ccircle fill='hsl(128, 8%, 22%)' cx='32' cy='32' r='32' /%3E%3Ctext x='50%25' y='55%25' dominant-baseline='middle' text-anchor='middle' fill='%23FFF' %3EA%3C/text%3E%3C/svg%3E)
