Ok dunque, per info, nel foglio dove arrivano le dde esiste già una funzione worksheet change, ma non dovrebbe andare in conflitto.
L'errore rimane, da cosa ho capito la finestra appare durante l'esecuzione di una di queste due righe:
Call MsgBox(Prompt:="Error " & Err.Number & " (" & Err.Description & ") nella routine: Tester", Buttons:=vbCritical, Title:="ERRORE")
Err.Clear
può essere ?
////////
ho commentato un altro On Error GoTo ErrHandler, pigiato play, crash di excel
Un saluto ed un ringraziamento
Daniel
Ciao Daniel,
Prt il momento, commenta o cancellare tutto il codice nel modulo del foglio.
Alt-F11 per aprire l'editor di VBA
Al-IM per inserire un secondo moduloi so codice (Modulo2?) e nel modulo nuovo incolla:
'==========>>
Option Explicit
'---------->>
Public Sub MySpreads2()
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 = 10
Const sReportShName As String = "Report" '<<==== Modifica
Const sCopyFileName As String = "C:\MyAlarms\Alarm.xls" '<<==== Modifica
'\ On Error GoTo ErrHandler '<<===RIGA COMMENTATA
'\ Application.ScreenUpdating = False '<<===RIGA COMMENTATA
dDate = Format(Date, "dd/mm/yy")
dTime = Format(Time, "hh:mm:ss")
Set WB = ThisWorkbook '<<==== Modifica
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 '<<=== Nuova riga temporanea
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
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 '<<===RIGA COMMENTATA
With ActiveWorkbook
.SaveAs Filename:=sCopyFileName, FileFormat:=52
.Close
End With
.DisplayAlerts = True
End With
'\ Call InformaDaniel(q, dTime, dDate, sCopyFileName) '<<===RIGA COMMENTATA
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
'<<==========
Alt-Q per chiudere l'editor VBA
Alt-F8 per aprire la finistrina delle Macro
Seleziona MySpread2 | Esegui (Nota il 2!)
Quando il codice si blocca, fammi sapere quale riga sia evidenziata in giallo.
===
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)
