VBA crash Excel

[Peltz]

Hi there. The code I've compild her crashes Excel, and I can't figure out whats wrong with it. I can open excel excel an other codes just fine. Isuspect it has something to do with sending multipe mails. Ive rand the code through the step through method, and it seems to work. Any help troubleshoting it would be greatly appreciated. I would happily send the full document if needed. Thanks!

Sub fristbrudd_spesifisert()
Dim ansatt As String
Dim sisterad As Integer
Dim sisterad1 As Integer
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim Siste As Long
Dim adresse As String
Dim i As Integer
Dim k As Integer
MsgBox "Kan ta noe tid å generere rapporter, finn noe kaffe", , "Oppfordring"
Sheets("Forefallende").Range("P2:U300").ClearContents
sisterad = Sheets("Pasientforløp").Range("A3000").End(xlUp).Row
sisterad1 = Sheets("Forefallende").Range("H1000").End(xlUp).Row
For k = 3 To sisterad1
ansatt = Sheets("Forefallende").Cells(k, 8) 'hvor navn for den som søkes hentes
adresse = Sheets("Forefallende").Cells(k, 9)

For i = 9 To sisterad
'fiks kopi
If Sheets("Pasientforløp").Cells(i, 5) = ansatt And Sheets("Pasientforløp").Cells(i, 5) <> "" And Sheets("Pasientforløp").Cells(i, 9) <> True And Now > Sheets("Pasientforløp").Cells(i, 7).Value Then
    Sheets("Forefallende").Range("P100").End(xlUp).Offset(1, 0) = Sheets("Pasientforløp").Cells(i, 10)
    Sheets("Forefallende").Range("Q100").End(xlUp).Offset(1, 0) = Sheets("Pasientforløp").Cells(i, 2)
    Sheets("Forefallende").Range("R100").End(xlUp).Offset(1, 0) = Sheets("Pasientforløp").Cells(i, 7)
    Sheets("Forefallende").Range("S100").End(xlUp).Offset(1, 0) = Sheets("Pasientforløp").Cells(i, 5)


End If
Next i
If Sheets("Forefallende").Range("P2") = "" Then

GoTo 10
End If

Siste = Sheets("Forefallende").Range("P1").CurrentRegion.Rows.Count
Set rng = Sheets("Forefallende").Range("P2: S" & Siste)

    On Error GoTo 0
    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
    .Display
    End With
    signature = OutMail.HTMLbody
    With OutMail
        .To = adresse
        .CC = ""
        .BCC = ""
        .Subject = "Oppfølging pakkeforløp"
        .HTMLbody = "<font size=""2"" face=""Calibri"" color=""black"">" & "Hei " & ansatt & "<br><br><br>" & _
        "Disse oppgavene er ikke fullførte eller avhuket i forløpsskjemaet" & vbNewLine & RangetoHTML(rng) & signature
        '.Send
        .Display
    End With
    On Error GoTo 0
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
10
If Sheets("Forefallende").Cells(2, 16) <> "" Then
Sheets("Forefallende").Range("O2") = 1
Sheets("Forefallende").Range("P2:U300").ClearContents
End If
Next k
If Sheets("Forefallende").Range("O2") = "" Then
MsgBox "Ingen frister utløpt", , "Søk ferdig"
Else: Sheets("Forefallende").Range("O2").ClearContents
End If


End Sub

 

[nemmi69]

I am having a quick look. One thing to note is the following

[COLOR=#333333]Siste = Sheets("Forefallende").Range("P1").CurrentRegion.Rows.Count
[/COLOR][COLOR=#333333]Set rng = Sheets("Forefallende").Range("P2: S" & Siste)
[/COLOR]

If Siste is 0 then the next line will error as you cannot have row 0

 

[Peltz]

Thanks. I've got a header (not table) in that row, so I dont think that is the problem. The problem seems to occure when trying to generate the third mail.