Delete unmatched rows in Excel
In your code there are several slow items:

1.


StrComp(Range("B" &amp; i), dontDelete(j, 1), vbTextCompare) = 0
I would use Range("B" &amp; i).Value2 = dontDelete(j, 1).Value2


2.


Like PeterT suggested deleting rows is quite slow, specially when you do it one at the time
I would hide the rows to keep, and at the end delete all visible rows in one operation


3.


Another significant performance issue is caused by interacting with the sheet
You could copy both ranges into 2 separate variants and loop them the same way as ranges




Bellow I'm providing a different approach:


create a new column with a formula that will find all matches from Account_Range
use AutoFilter to hide the rows you want to keep
delete all visible rows in one operation




Option Explicit

Public Sub DeleteRowsFilter()
  Const FAR_ROW1 As Long = 3

  Dim lrInput As Long, lrFAR As Long, lcFAR As Long, lastCell As Range
  Dim srcRng As String, fCell As Range, formulaRng As Range, t As Double

  FastWB
  t = Timer

  With ThisWorkbook.Worksheets("FAR")
    Set lastCell = GetMaxCell(.UsedRange)
    lrFAR = lastCell.Row
    lcFAR = lastCell.Column

    'create a new column showing if row should be deleted (value = 0) or not (value &gt; 0)
    Set fCell = .Cells(FAR_ROW1, lcFAR + 1)
    fCell.Formula = "=IFERROR(MATCH(B" &amp; FAR_ROW1 &amp; ",Account_Range,0),0)"

    'fill down the formula to last row
    Set formulaRng = .Range(fCell, .Cells(lrFAR, lcFAR + 1))
    fCell.AutoFill Destination:=formulaRng: .Calculate

    'hide the rows to keep
    formulaRng.AutoFilter Field:=1, Criteria1:="=0"

    'delete visible rows (not matching values in Account_Range)
    fCell.Offset(1).Resize(lrFAR - FAR_ROW1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    .Columns(lcFAR + 1).EntireColumn.Delete 'delet last column (temp formula)
  End With

  Debug.Print "Duration:" &amp; vbTab &amp; Format(Timer - t, "#,##0.0000") &amp; " sec" &amp; vbCrLf
  FastWB False
End Sub




In my test file I only used 2 columns on each sheet, both with 10,000 rows 
This version deleted more than 6,000 rows

Total Duration:   1.9338 sec



I also used 2 helper functions

Turn off visual elements:

Public Sub FastWB(Optional ByVal opt As Boolean = True)
    With Application
        .Calculation = IIf(opt, xlCalculationManual, xlCalculationAutomatic)
        .DisplayAlerts = Not opt
        .DisplayStatusBar = Not opt
        .EnableAnimations = Not opt
        .EnableEvents = Not opt
        .ScreenUpdating = Not opt
    End With
End Sub




Determine the last row and column:

Public Function GetMaxCell(Optional ByRef rng As Range = Nothing) As Range

    'Returns the last cell containing a value, or A1 if Worksheet is empty

    Const NONEMPTY As String = "*"
    Dim lRow As Range, lCol As Range

    If rng Is Nothing Then Set rng = Application.ActiveWorkbook.ActiveSheet.UsedRange
    If WorksheetFunction.CountA(rng) = 0 Then
        Set GetMaxCell = rng.Parent.Cells(1, 1)
    Else
        With rng
            Set lRow = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
                                        After:=.Cells(1, 1), _
                                        SearchDirection:=xlPrevious, _
                                        SearchOrder:=xlByRows)
            If Not lRow Is Nothing Then
                Set lCol = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
                                            After:=.Cells(1, 1), _
                                            SearchDirection:=xlPrevious, _
                                            SearchOrder:=xlByColumns)

                Set GetMaxCell = .Parent.Cells(lRow.Row, lCol.Column)
            End If
        End With
    End If
End Function