Question

我希望能够将大约30k行（确切地说，只是行的某些元素）从表A复制到表B，从行nr 36155开始目标。有时，我们不止一次复制行，取决于G列中的数字。这是我写的宏：

Sub copy()
ActiveSheet.DisplayPageBreaks = False
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculate

Dim k As Long, k1 As Long, i As Integer

k = 36155
k1 = 30000

For i = 1 To k1
For j = 1 To Sheets("A").Range("G" & i + 2).Value
    Sheets("B").Range("A" & k).Value = Sheets("A").Range("A" & i + 2).Value
    Sheets("B").Range("B" & k).Value = Sheets("A").Range("B" & i + 2).Value
    Sheets("B").Range("C" & k).Value = j
    Sheets("B").Range("D" & k).Value = Sheets("A").Range("C" & i + 2).Value
    Sheets("B").Range("E" & k).Value = Sheets("A").Range("D" & i + 2).Value
    Sheets("B").Range("F" & k).Value = Sheets("A").Range("E" & i + 2).Value
    Sheets("B").Range("G" & k).Value = Sheets("A").Range("F" & i + 2).Value
    Sheets("B").Range("H" & k).Value = Sheets("A").Range("I" & i + 2).Value + (j - 1) * Sheets("A").Range("H" & i + 2).Value
    Sheets("B").Range("I" & k).Value = Sheets("A").Range("J" & i + 2).Value
    k = k + 1
Next j
Next i


Application.EnableEvents = True
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

不幸的是，这个宏需要花费很多时间才能运行（大约10分钟）。我有一种感觉，可能有更好的方法来做到这一点。你有什么想法，我们怎样才能增强宏？

Answer 1

我建议您将数据读入记录集as shown here，然后循环记录集。

尝试以下（未经测试）。

Sub copy()

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculate
        .Calculation = xlCalculationManual
    End With

    Dim k As Long, i As Integer

    k = 36155

    ' read data into a recordset
    Dim rst As Object
    Set rst = GetRecordset(ThisWorkbook.Sheets("A").UsedRange) 'feel free to hard-code your range here

    With rst
        While Not .EOF

            For j = 1 To !FieldG
          ' !FieldG accesses the Datafield with the header "FieldG". Change this to the header you actually got in Column G, like "!MyColumnG" or ![columnG with blanks]

                Sheets("B").Cells(k, 1).Value = !FieldA
                ' ... your code

                k = k + 1
            Next j

            .movenext
        Wend

    End With


    With Application
        .EnableEvents = True
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

还要将以下功能添加到您的VBA模块中。

Function GetRecordset(rng As Range) As Object

    'Recordset ohne Connection:
    'https://usefulgyaan.wordpress.com/2013/07/11/vba-trick-of-the-week-range-to-recordset-without-making-connection/

    Dim xlXML As Object
    Dim rst As Object

    Set rst = CreateObject("ADODB.Recordset")
    Set xlXML = CreateObject("MSXML2.DOMDocument")
    xlXML.LoadXML rng.Value(xlRangeValueMSPersistXML)

    rst.Open xlXML

    Set GetRecordset = rst

End Function

注意： - 使用记录集为您提供过滤数据等附加选项 - 使用记录集，您不依赖于输入数据的列顺序，这意味着如果您决定向表A添加另一列，则不必调整宏（只要保持标题相同）

希望这有帮助。

Answer 2

尝试使用变体数组：如果可以使用包含多于1行的B数组，则可能更快。这个版本在我的电脑上需要17秒。

Sub Copy2()
    ActiveSheet.DisplayPageBreaks = False
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculate
    '
    Dim k As Long, k1 As Long, i As Long, j As Long
    Dim varAdata As Variant
    Dim varBdata() As Variant
    '
    Dim dT As Double
    '
    dT = Now()
    '
    k = 36155
    k1 = 30000
    '
    ' get sheet A data into variant array
    '
    varAdata = Worksheets("A").Range("A1:J1").Resize(k1 + 2).Value2
    '
    For i = 1 To k1
        'For j = 1 To Sheets("A").Range("G" & i + 2).Value
        For j = 1 To varAdata(i + 2, 7)
            '
            ' create empty row of data for sheet B and  fill from variant array of A data
            '
            ReDim varBdata(1 to 1,1 to 9) As Variant
            'Sheets("B").Range("A" & k).Value = Sheets("A").Range("A" & i + 2).Value
            varBdata(1, 1) = varAdata(i + 2, 1)
            varBdata(1, 2) = varAdata(i + 2, 2)
            varBdata(1, 3) = j
            varBdata(1, 4) = varAdata(i + 2, 3)
            varBdata(1, 5) = varAdata(i + 2, 4)
            varBdata(1, 6) = varAdata(i + 2, 5)
            varBdata(1, 7) = varAdata(i + 2, 6)
            varBdata(1, 8) = varAdata(i + 2, 9) + (j - 1) * varAdata(i + 2, 8)
            varBdata(1, 9) = varAdata(i + 2, 10)
            '
            ' write to sheet B
            '
            Sheets("B").Range("A1:I1").Offset(k - 1).Value2 = varBdata
            k = k + 1
        Next j
    Next i
    '
    Application.EnableEvents = True
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox (Now() - dT)
End Sub

在VBA中复制大量数据excel

2 个答案: