Превышение лимита строк - создать новый лист

Question

У меня есть 2 столбца на листе «список», один столбец, в котором перечислены все бизнес-объекты, а другой - все организационные единицы.Функциональность приведенного ниже кода работает отлично, но возвращает ошибку, поскольку она превышает предел строки листа.

Данные вставляются на лист "cc_act". Есть ли способ в момент ошибки создать новый лист с именем "cc_act1" .... "cc_act2", пока сценарий не будет завершен?

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

Полагаю, есть несколько способов справиться с чем-то подобным. См. Пример кода ниже и адаптируйте его к вашим конкретным потребностям.

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

Кроме того, вы можете рассмотреть возможность использования MS Access для такого рода вещей. Или, еще лучше, Python или даже R. Удачи в вашем проекте.