Ok a questo punto riesco a far riportare solo una delle due quotazioni.
In sostanza ho due di queste stringhe:
oDic2.Add Key:=.Offset(0, -1), Item:=.Offset(0, 1)
Se le sostituisco entrambe con:
oDic2.Add Key:=.Offset(0, -1), Item:=.Offset(0, 15)
excel va in crash, se invece ne sostituisco solo una di queste no, ma viene riportata solo una di queste quotazioni.
Tutto questo prima ancora di aver sostituito:
With SH
iLastRow = LastRow(SH, .Columns("A:A"))
Set Rng = .Range("A1:C" & iLastRow)
End With
con
With SH
iLastRow = LastRow(SH, .Columns("A:A"))
Set Rng = .Range("A1:Q" & iLastRow)
End With
Se eseguo l'ultima sostituzione il discorso non cambia.
N.B. sto lavorando sempre con le due stringhe:
'On Error GoTo ErrHandler
commentate
Un saluto e grazie ancora
Daniel
Ciao Daniel,
Prova a sostituire il codice con :
'==========>>
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" '<<==== Modifica
Const sCopyFileName As String = "C:\MyAlarms\Alarm.xls" '<<==== Modifica
'\On Error GoTo ErrHandler
'<<===RIGA COMMENTATA
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 '<<===RIGA COMMENTATA
On Error GoTo 0
'<<=== riga temporanea
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, 1)
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:=xlWorkbookNormal '=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 = "******@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
'<<==========
===
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)
