Ciao Daniel,
C'è chiaramente qualcosa di molto particolare circa la natura, la configurazione o la disposizione dei tuoi dati, ma mi dispiace che sono stato incapace di carpire tali informazioni.
Io elenco qui di seguito i miei dati, il codice utilizzato ed i risultati delle ultime due prove; tutti i miei test hanno aggiornato il file Alarms.xlsx e hanno fornito, con successo, un avviso e-mail.
I dati di origine che ho usato erano:
| TITOLO |
ID |
QUOTE |
| Fiat |
ITALIA |
8.56 |
| Eni |
ITALIA |
18.61 |
| Finmeccanica |
ITALIA |
6.42 |
| Carrefour |
FRANCIA |
28.60 |
| Peugeout |
FRANCIA |
12.96 |
| Mercedes |
GERMANIA |
17.25 |
| Vw |
GERMANIA |
28.75 |
| Audi |
GERMANIA |
6.95 |
| Polo |
GERMANIA |
3.00 |
I risultati delle ultime due prove che, insieme con i risultati di tutti i test precedenti sono tutti registrati nel file Alarms.xlsx, erano:
| ITALIA |
Fiat |
8.56 |
Eni |
18.61 |
-10.05 |
24/04/2014 |
22:24:36 |
| ITALIA |
Fiat |
8.56 |
Finmeccanica |
6.42 |
2.14 |
24/04/2014 |
22:24:36 |
| ITALIA |
Eni |
18.61 |
Finmeccanica |
6.42 |
12.19 |
24/04/2014 |
22:24:36 |
| FRANCIA |
Carrefour |
28.60 |
Peugeout |
12.96 |
15.64 |
24/04/2014 |
22:24:36 |
| GERMANIA |
Mercedes |
17.25 |
Vw |
28.75 |
-11.50 |
24/04/2014 |
22:24:36 |
| GERMANIA |
Mercedes |
17.25 |
Audi |
6.95 |
10.30 |
24/04/2014 |
22:24:36 |
| GERMANIA |
Mercedes |
17.25 |
Polo |
3.00 |
14.25 |
24/04/2014 |
22:24:36 |
| GERMANIA |
Vw |
28.75 |
Audi |
6.95 |
21.80 |
24/04/2014 |
22:24:36 |
| GERMANIA |
Vw |
28.75 |
Polo |
3.00 |
25.75 |
24/04/2014 |
22:24:36 |
| GERMANIA |
Audi |
6.95 |
Polo |
3.00 |
3.95 |
24/04/2014 |
22:24:36 |
|
|
|
|
|
|
|
|
| ITALIA |
Fiat |
8.56 |
Eni |
18.61 |
-10.05 |
24/04/2014 |
22:24:38 |
| ITALIA |
Fiat |
8.56 |
Finmeccanica |
6.42 |
2.14 |
24/04/2014 |
22:24:38 |
| ITALIA |
Eni |
18.61 |
Finmeccanica |
6.42 |
12.19 |
24/04/2014 |
22:24:38 |
| FRANCIA |
Carrefour |
28.60 |
Peugeout |
12.96 |
15.64 |
24/04/2014 |
22:24:38 |
| GERMANIA |
Mercedes |
17.25 |
Vw |
28.75 |
-11.50 |
24/04/2014 |
22:24:38 |
| GERMANIA |
Mercedes |
17.25 |
Audi |
6.95 |
10.30 |
24/04/2014 |
22:24:38 |
| GERMANIA |
Mercedes |
17.25 |
Polo |
3.00 |
14.25 |
24/04/2014 |
22:24:38 |
| GERMANIA |
Vw |
28.75 |
Audi |
6.95 |
21.80 |
24/04/2014 |
22:24:38 |
| GERMANIA |
Vw |
28.75 |
Polo |
3.00 |
25.75 |
24/04/2014 |
22:24:38 |
| GERMANIA |
Audi |
6.95 |
Polo |
3.00 |
3.95 |
24/04/2014 |
22:24:38 |
Il codice utilizzato era:
'==========>>
Option Explicit
'---------->>
Public Sub MySpreads3()
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"
Const mioParametro As Double = 0
Const sReportShName As String = "Report"
Const sCopyFileName As String = "C:\MyAlarms\Alarm.xlsx" '<<==== 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
With SH
iLastRow = LastRow(SH, .Columns("Q:Q"))
Set Rng = .Range("A1:Q" & 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, 15)
End If
Else
Set oDic2 = CreateObject("Scripting.Dictionary")
oDic2.CompareMode = vbTextCompare
oDic2.Add Key:=.Offset(0, -1), Item:=.Offset(0, 15)
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
Debug.Print "arrChildItems(" & j & ")=" & arrChildItems(j) & vbTab _
& "arrChildItems(" & p & ")= " & arrChildItems(p)
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
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:=52
.Close
End With
.DisplayAlerts = True
End With
Call InformaDaniel(q, dTime, dDate, sCopyFileName)
XIT:
Set oDic2 = Nothing
Set oDic = Nothing
Application.ScreenUpdating = True
On Error GoTo 0
'\Exit Sub
ErrHandler: '<<===RIGA COMMENTATA
'\ Call MsgBox(Prompt:="Error " _
'\ & Err.Number _
'\ & " (" _
'\ & Err.Description _
'\ & ") nella routine: Tester", _
'\ Buttons:=vbCritical, _
'\ Title:="ERRORE") '<<===RIGA COMMENTATA
'\ 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 = .To = "topoDOTgiggioAToutlookDOTcom" '<<==== Modifica
.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
'<<==========
Per simulare le ripetute chiamate al codice, causato nel tuo caso per DDE, ho eseguito il mio codice in un ciclo 1x100 usando il codice:
'==========>>
Public Sub Demo()
Dim i As Long
For i = 1 To 100
Call MySpreads3
Next i
End Sub
'<<==========
Questo codice è stato com completato senza errori - fatta eccezione per le dimensioni del mio casella di email!
Come un ultimo tentativo per aiutarti, per verificare il codice ed eliminare qualsiasi problema che possa derivarsi dalle formule utilizzate per collegare il foglio di dati al foglio DDE, ti suggerisco di copiare il foglio di dati (Foglio1)su un
nuovo foglio, utilizzando una operazione di Copia | Incolla Speciale | Valori per produrre una copia
'statica' dei dati. Prima dell'esecuzione del codice, sostituisci "Foglio1" con il nome del nuovo foglio.
Fammi sapere se il codice ora producono i risultati desiderati.
===
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)
