Report Split - Excel VBA Doesn't Copy all Rows and runs Indefinetly - vba

Question

I have written the following Excel VBA Macro, its job is to split a report based on CountryCode. It creates a new workbook, copies the relevant rows to a new workbook, saves the workbook by the CountryCode.
The problem I encouter is missing rows and for one worksheet, it continues running on empty rows? - Basically it doesn't stop and copies over empty rows.
Has cell formatting anything to do with it?
There is another Macro that runs only once which creates the workbooks first. It is only run once on the first worksheet, never again.
Sub RUN2_ReportSplitterOptimized()
Application.DisplayAlerts = False
Application.EnableEvents = False
' Current Workbook
Dim cW As Workbook
Dim cWL As String
Dim cWN As String
Set cW = ThisWorkbook
cWL = cW.Path
cWN = cW.Name
' Current Worksheet
Dim cS As Worksheet
Set cS = ActiveSheet
Do Until IsEmpty(ActiveCell)
' Current Active Cell
Dim aC As Range
Set aC = ActiveCell
' Split input string
Dim CC As String
CC = splitCC(aC.Text)
Dim wb As Workbook
Dim ws As Worksheet
On Error Resume Next
Set wb = Workbooks(CC & ".xlsx")
If Err.Number <> 0 Then
Set wb = Workbooks.Open(cWL & "\" & CC & ".xlsx")
' Create the worksheet
Set ws = wb.Sheets.Add
' Copy the row to the worksheet
ws.Rows(1).Value = cS.Rows(1).Value
ws.Rows(2).Value = aC.EntireRow.Value
With ws
.Name = cS.Name
End With
Else
wb.Activate
On Error Resume Next
Set ws = wb.Sheets(cS.Name)
If Err.Number <> 0 Then
Set ws = wb.Sheets.Add
' Copy the row to the worksheet
ws.Rows(1).Value = cS.Rows(1).Value
ws.Rows(2).Value = aC.EntireRow.Value
With ws
.Name = cS.Name
End With
Else
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
ws.Rows(LastRow + 1).Value = aC.EntireRow.Value
End If
End If
wb.Save
cW.Activate
aC.Offset(1, 0).Select
Loop
Dim wbk As Workbook
For Each wbk In Workbooks
If Len(wbk.Name) = 7 Then
wbk.Close
End If
Next
End Sub
Function splitCC(countrycode As String) As String
If Len(countrycode) < 3 Then
splitCC = countrycode
Else
splitCC = Mid(countrycode, InStr(countrycode, "(") + 1, 2)
End If
End Function

Answer 1

Solved it.
I have used filters as recommended by #sous2817
Instead of running couple of hours - it does the entire job within 2 minutes :D
Thanks for your help
Problem has been solved here: Excel VBA AutoFilter adds empty rows