Ftyjtk

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