Try this amendment
Public Sub ExtractAcNumbers()
Dim wsShareholders As Worksheet
Dim wsFinal As Worksheet
Dim target As String
Dim lastrow As Long
Dim nextrow As Long
Dim i As Long
Application.ScreenUpdating = False
Set wsShareholders = Worksheets("Shareholders")
Set wsFinal = Worksheets("Final")
With wsFinal
.Columns(1).ClearContents
nextrow = 1
With .Cells(nextrow, "A")
.Value = "Dealer Account Number"
.Font.Bold = True
.Font.Underline = True
End With
End With
With wsShareholders
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To lastrow
If .Cells(i, "A").Value = "Account Number" Then
target = vbNullString
Do
i = i + 1
If Left$(.Cells(i, "A").Value, 9) = "(DLR A/C:" Then
target = Mid$(.Cells(i, "A").Value, 10, Len(.Cells(i, "A").Value) - 10)
End If
Loop Until .Cells(i, "A").Value = "Account Number" Or i > lastrow
nextrow = nextrow + 1
wsFinal.Cells(nextrow, "A").Value = target
i = i - 1
End If
Next i
End With
Application.ScreenUpdating = True
End Sub