Sub rtfToExcel(filename As String, sheetName As String)

    Application.ScreenUpdating = False
    Dim WordApp As Object
    Dim toSheet As Worksheet
    Set WordApp = CreateObject("Word.Application")
    Set toSheet = ThisWorkbook.Sheets(sheetName)
    
    With WordApp
        .Documents.Open filename
        .ActiveDocument.Select
        .Selection.Copy
    End With
    
    toSheet.Paste
    Application.CutCopyMode = False
    WordApp.Quit
    Set WordApp = Nothing
    Application.ScreenUpdating = True
End Sub