Cfrgtkky

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

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.