excel - 超出行数限制 - 创建新工作表

Question

我在工作表“列表”上有两列，一列列出所有业务实体，另一列列出所有组织单位。下面代码的功能完美运行，但返回错误，因为它超出了工作表行限制。

数据被粘贴到工作表“cc_act”上是否有办法在错误点创建一个名为“cc_act1”....“cc_act2”的新工作表，直到脚本完成？

Declare Function HypMenuVRefresh Lib "HsAddin" () As Long

子抄送()

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。祝你的项目好运。