Workbook split hangs up here - vba

Question

The project: It deals with very sensitive HR/performance data, and I need to send 1000s of employees' data to their individual managers (about 100 managers who can only see their team's data, and no one else's), so I need about 100 files split (1 for each manager).
The file: - Many different tabs, separated by role. - First column is a unique identifier made by concatenating the Manager's name with the job title ex. John Stevens_Office Manager
The task: John Stevens will have team members in many different job roles, and needs all that data in one file, separated into tabs by job role.
Based on that sample data, the ideal macro would give me 3 files with 3 worksheets in each, and 1 row of data in each worksheet. However, I will settle for the worksheet being split into multiple files.
Here is my code.
Sub SplitWB()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
ActiveWorkbook.Save
Dim OutputFolderName As String
OutputFolderName = ""
Set myDlg = Application.FileDialog(msoFileDialogFolderPicker)
myDlg.AllowMultiSelect = False
myDlg.Title = "Select Output Folder for Touchstone Files:"
If myDlg.Show = -1 Then OutputFolderName = myDlg.SelectedItems(1) & "\" Else Exit Sub
Set myDlg = Nothing
Application.CutCopyMode = False
'''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''
Dim d As Object, c As Range, k, tmp As String, unique(500)
i = 0
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Set d = CreateObject("scripting.dictionary")
For Each c In Range(Cells(1, 1), Cells(lastRow, 1))
tmp = Trim(c.Value)
If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
Next c
For Each k In d.keys
Debug.Print k, d(k)
i = i + 1
unique(i) = k
Next k
UniqueCount = i
'start deleting
For i = 1 To UniqueCount
'Actions for new workbook
wpath = Application.ActiveWorkbook.FullName
wbook = ActiveWorkbook.Name
wsheet = ActiveSheet.Name
ActiveWorkbook.SaveAs Filename:=OutputFolderName & unique(i), FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
For j = 1 To lastRow
If Range("A" & j) <> "" And Range("A" & j) <> unique(i) Then
Rows(j).Delete
j = j - 1
End If
Next
'hide helper columns
' If HideC = False And DeleteC = True Then
Columns("A:D").Hidden = True
' End If
'
Range("E8").Select
'Select Instructions tab
'Worksheets("Guidelines").Activate
'Save new workbook
ActiveWorkbook.Close SaveChanges:=True
Workbooks.Open (wpath)
'ActiveWorkbook.Close False
Workbooks(wbook).Activate
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox ("Macro has completed successfully!" & vbNewLine & vbNewLine & "Generated files can be found in the following directory:" & vbNewLine & OutputFolderName)
End Sub
The code hangs at "If Range("A" & j) <> "" And Range("A" & j) <> unique(i) Then"
It is located about half-way into the code and the chunk starts with "For j = 1 To lastRow"
Please help. It will literally save me a day's work or more. Thanks!!!

Answer 1

Try
For j = lastRow to 1 step -1
If Range("A" & j) <> "" And Range("A" & j) <> unique(i) Then
Rows(j).Delete
End If
Next
instead. This allows you to loop backwards so when you delete a row it won't lose track of where you want j to be in the loop.