Question

我创建了一个大型VBA程序，以自动创建在Excel文件中运行切片器所需的数据表。虽然循环可以很好地创建我需要的东西。主循环需要一个小时来创建我需要的公司名称列表。我想知道是否有一种方法可以缩短循环完成所需的时间。我有191行需要复制，然后每行粘贴68次到新表中。我尝试了几种不同的方法来缩短时间，并且仅将所需时间减少到大约50分钟。任何帮助将非常感激。我知道使用select会浪费时间，但是我尝试过的所有其他选项都效果不佳。

Dim rng As Range, cell As Range
For Each cell In rng

    Sheets("Input Data").Select
    cell.Select
    cell.Copy
    Sheets("TrialSheet").Select
    For i = 1 To 68
        LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
        Range("A" & LastRow).Select
        ActiveSheet.Paste
    Next i

    Sheets("Input Data").Select

Next cell

Answer 1

请删除最后一个Sheets("Input Data").Select-这是不必要的，因为循环以此开始。
其次，内部的for循环可以替换为该操作，该操作可以批量填充一个范围：

LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
Range("A" & LastRow & ":A" & LastRow + 68).PasteSpecial

我认为它应该更快，但可能需要进一步调整。

Answer 2

与其复制和粘贴单元格，不如将它们一次读取到内存中成二维数组并将该数组写入目标。这样可以大大加快该过程。

缺点（或优点，取决于您的需要）：仅复制值。

Sub CopyRange(sourceRange As Range, destRange As Range, Optional howOften As Long = 1)

    Dim arr As Variant
    ' Fill arr with all values of sourceRange
    arr = sourceRange.Value2
    ' Adjust size of destination range
    Set destRange = destRange.Resize(sourceRange.Rows.count, sourceRange.Columns.count)
    Dim i As Long
    For i = 1 To howOften
        ' Copy the values to the destination
        destRange.Value2 = arr
        ' Move to the next place 
        Set destRange = destRange.Offset(sourceRange.Rows.count)
    Next
End Sub

假设rng设置为您要复制的范围，则对例程的调用看起来像

call CopyRangeSheets(rng, ThisWorkbook.Sheets("TrialSheet").Range("A1"), 68)

Answer 3

由于没有有关复制源范围大小的信息

假设问题的灰色区域如下

由于191行X 68副本X 3列仅花费大约10分钟（使用您的代码），因此范围约为191行X 15列大小
因为已经声称代码可以正常工作。范围的单元格（无论它们的行或列位置如何）仅被复制到列A中（一个或另一个）。尽管它与“自动创建数据表”语句相矛盾
因为要复制和粘贴范围的单元格，所以。在测试用例中，仅复制公式。

因此，下面的代码将复制您的代码，并提高效率。由于我个人不希望保留计算，事件处理和屏幕更新（通常情况下），因此我没有添加标准行。但是，根据工作文件的情况，您可以使用这些标准技术。对范围等进行必要的更改

代码只需2-3秒即可完成191行X 15列X 68份：

Sub test()
Dim SrcWs As Worksheet, DstWs As Worksheet, SrcArr As Variant
Dim Rng As Range, cell As Range, DstArr() As Variant
Dim X As Long, Y As Long, Z As Long, i As Long, LastRow As Long
Dim Chunk60K As Long
Dim tm As Double
tm = Timer
Set SrcWs = ThisWorkbook.Sheets("Input Data")
Set DstWs = ThisWorkbook.Sheets("TrialSheet")

Set Rng = SrcWs.Range("A1:O191")
SrcArr = Rng.Formula

LastRow = DstWs.Cells(Rows.Count, "A").End(xlUp).Row + 1
Chunk60K = 0
Z = 1
    For X = 1 To UBound(SrcArr, 1)
    For Y = 1 To UBound(SrcArr, 2)
    For i = 1 To 68
        ReDim Preserve DstArr(1 To Z)
        DstArr(Z) = SrcArr(X, Y)

        If Z = 60000 Then  ' To Overcome 65K limit of Application.Transpose
        DstWs.Range("A" & Chunk60K * 60000 + LastRow).Resize(UBound(DstArr, 1), 1).Formula = Application.Transpose(DstArr)
        Chunk60K = Chunk60K + 1
        Z = 1
        ReDim DstArr(1 To 1)
        Debug.Print "Chunk: " & Chunk60K & " Seconds Taken: " & Timer - tm
        Else
        Z = Z + 1
        End If

    Next i
    Next Y
    Next X

If Z > 1 Then DstWs.Range("A" & Chunk60K * 60000 + LastRow).Resize(UBound(DstArr, 1), 1).Formula = Application.Transpose(DstArr)

Debug.Print "Seconds Taken: " & Timer - tm
End Sub

如何为大型应用程序提高循环效率

3 个答案: