Macro confronto celle

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

Buongiorno Norman,

i tuoi sospetti erano fondati ! Ora funziona tutto correttamente.

A questo punto devo solo impostare la condizione ideale per richiamare questa routine.

Stavo pensando che nel caso in cui la ruotine si aggiornasse per worksheetchange o simili (dunque real time) rischerebbe forse di produrre spam qualora lo spreads tra due titoli si mantenesse sopra un determinato livello per un certo lasso di tempo (a meno che non sia prevista la condizione "cross" anzichè maggiore/minore che risolverebbe il problema) e se questo fosse vero, forse la soluzione migliore sarebbe aggiornare il foglio hour by hour.

Grazie ancora per il tuo aiuto, se hai tempo e voglia dimmi anche solo se la mia considerazione può essere corretta o meno, poi cerco di aggiustarmi.

Un saluto

Daniel

Ciao Daniel,

Non credo che ci sia un significato intrinseco nell'utilizzo dei tuoi valori percentuali. Le percentuali non sono altro che un modo per rappresentare un numero. 

Tuttavia, nel caso dei valori indicati, le differenze nei valori delle coppie sono estremamente piccole, ad esempio 2,6*10^-5. Pertanto, sarebbe interessante sapere quale valore sia stato utilizzato da te per la costante mioParemetro. 

Nel mio test, soggetto ad un valore sufficientemente piccolo per questo parametro, non ho riscontrato alcun problema. 

Avevo volutamente lasciato un messaggio di errore nel mio codice per scopi di prova e ora mi viene in mente che forse stia confondendo il messaggio di errore con un 'crash' di Excel: infatti, sono eventi molto diversi. 

In ogni caso, nella  procedura mySpreads , prova a sostituire la riga:

        With destRng.Resize(q, UBound(arrOut, 1))

con

        If Not CBool(q) Then GoTo XIT

        With destRng.Resize(q, UBound(arrOut, 1))

Ho il sospetto che non ci saranno più crash!

===

Regards,

Norman