Exceeding row limit - create new sheet - excel

Question

I have 2 columns on a sheet "list", one column that lists all business entities, the other lists all org units. The functionality of the code below works perfectly but returns an error because it exceeds the sheet row limit.
The data is pasted onto a sheet "cc_act" is there a way to at point of error create a new sheet called "cc_act1"...."cc_act2" until the script is complete?
Declare Function HypMenuVRefresh Lib "HsAddin" () As Long
Sub cc()
Application.ScreenUpdating = False
Dim list As Worksheet: Set list = ThisWorkbook.Worksheets("list")
Dim p As Worksheet: Set p = ThisWorkbook.Worksheets("p")
Dim calc As Worksheet: Set calc = ThisWorkbook.Worksheets("calc")
Dim cc As Worksheet: Set cc = ThisWorkbook.Worksheets("cc_act")
Dim cc_lr As Long
Dim calc_lr As Long: calc_lr = calc.Cells(Rows.Count, "A").End(xlUp).Row
Dim calc_lc As Long: calc_lc = calc.Cells(1,
calc.Columns.Count).End(xlToLeft).Column
Dim calc_rg As Range
Dim ctry_rg As Range
Dim i As Integer
Dim x As Integer
list.Activate
For x = 2 To Range("B" & Rows.Count).End(xlUp).Row
If list.Range("B" & x).Value <> "" Then
p.Cells(17, 3) = list.Range("B" & x).Value
End If
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
If list.Range("A" & i).Value <> "" Then
p.Cells(17, 4) = list.Range("A" & i).Value
p.Calculate
End If
p.Activate
Call HypMenuVRefresh
p.Calculate
'''changes country on calc table
calc.Cells(2, 2) = p.Cells(17, 4)
calc.Cells(2, 3) = p.Cells(17, 3)
calc.Calculate
'''copy the calc range and past under last column
With calc
Set calc_rg = calc.Range("A2:F2" & calc_lr)
End With
With cc
cc_lr = cc.Cells(Rows.Count, "A").End(xlUp).Row + 1
calc_rg.Copy
cc.Cells(cc_lr, "A").PasteSpecial xlPasteValues
End With
Next i
Next x
Application.ScreenUpdating = True
End Sub

Answer 1

I suppose there are a few ways to handle something like this. See the code sample below, and adapt it to your specific needs.
Sub LongColumnToAFewColumns()
Dim wsF As Worksheet, WST As Worksheet
Dim rf As Range, rT As Range
Dim R As Long, j As Integer
' initialize
Set wsF = ActiveSheet
Set WST = Sheets.Add
WST.Name = "Results"
j = 1
For R = 1 To wsF.Cells(Rows.Count, 1).End(xlUp).Row Step 65536
wsF.Cells(R, 1).Resize(65536).Copy
WST.Cells(j, 1).PasteSpecial xlPasteValues
WST.Cells(j, 1).PasteSpecial xlPasteValues
j = j + 1
Next R
End Sub
As an aside, you may want to consider using MS Access for this kind of thing. Or, better yet, Python or even R. Good luck with your project.