粘贴数组中的行答案

【问题标题】：Paste row from an array粘贴数组中的行
【发布时间】：2015-11-17 15:35:59
【问题描述】：

我已经尝试了几个小时将 VBA 数组中的一行粘贴到 Excel 工作表中。

代码应该是这样的：

Dim wsSource As Worksheet
Set wsSource = Sheets("Data Retrieval - Source")
Dim wsDestination As Worksheet
Set wsDestination = Sheets("Data Retrieval - Destination")
Dim TableAbarSource
TableAbarSource = wsSource.Range("A3:U299729")

wsDestination.Range("A3:Z3") = ?

有什么想法吗？

非常感谢您的帮助！

添加了我需要在下面优化的原始代码（工作正常）。如您所见，有近 300,000 个循环，因此将表声明为变量是有一定意义的。

Sub DataRetrieval()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'Variable definitions
    'Worksheets
Dim wsSource As Worksheet
Set wsSource = Sheets("Data Retrieval - Source")
Dim wsDestination As Worksheet
Set wsDestination = Sheets("Data Retrieval - Destination")
Dim wsDefaultList As Worksheet
Set wsDefaultList = Sheets("Default List")

    'Core ID
Dim CoreIDSource As Long 'Core ID number of the sheet Data Retrieval - Source
Dim CoreIDModel As Long 'Core ID number of the sheet Model
Dim ComparingCoreID As Variant

    'Count
Dim RowCountSource As Long 'Count the rows of the sheet Data Retrieval - Source
Dim RowCountDestination As Long 'Count the rows of the sheet Data Retrieval (destination)
RowCountDestination = 4

'Preparing sheet Data Retrieval (destination)
wsDestination.Range("A3:CC500000").Delete

With wsSource 'Copy header
    .Range(.Cells(3, 1), .Cells(3, 200)).Copy wsDestination.Cells(3, 1) 'Copy table header
End With

'Comparing Core ID of source sheet to Core ID of Model sheet
For RowCountSource = 4 To 300000

    CoreIDSource = wsSource.Cells(RowCountSource, 2)

    Set ComparingCoreID = wsDefaultList.Range("B4:B1507").Cells.Find(What:=CoreIDSource, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False) 'Definition of the Find variable 'Do not use variables for range to save time

    If Not ComparingCoreID Is Nothing Then
        With wsSource
        .Range(.Cells(RowCountSource, 1), .Cells(RowCountSource, 200)).Copy wsDestination.Cells(RowCountDestination, 1) 'Copier les données chiffrées
        End With
        RowCountDestination = RowCountDestination + 1
    End If

Next RowCountSource

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

【问题讨论】：

您是否有理由要使用数组？为什么不简单地wsdestination.Rows(3).value = wsSource.rows(3).value？
能否也提供论坛链接？
这是因为宏会将 299,726 个数字与 1,700 个数字进行比较，如果数字匹配，则将该行复制粘贴到另一张纸上。我想使用数组来加速这个过程。我无法正确使用的一段有趣代码的链接：stackoverflow.com/questions/25185230/…
为此，您将需要循环。然后，您将使用两个变量，而不是 3 指示行。一个根据循环指示要复制的行，第二个根据查找下一个打开的行指示要粘贴的行。如何做到这一点的例子有很多。谷歌“根据特定值复制粘贴行”。您仍然不需要数组。范围本身就是一个数组。您仍然需要遍历数组。
或者您可以遍历 1700 个数字并使用过滤器，复制可见单元格，然后将它们粘贴到您想要的位置。

标签： arrays excel vba row

【解决方案1】：

可能有 100 种不同的方法可以做到这一点：

Sub test()

Dim rSource As Range
Dim rDest As Range

Set rSource = Sheet1.Range("A1:D100")
Set rDest = Sheet2.Range("A1")
Call rSource.Resize(1).Copy(rDest)

End Sub

这样的事情可能就足够了。根据需要更改线路呼叫来自：

rSource.Resize(1).Copy(rDest)

类似于：

Call rSource.Resize(1).offset(10).Copy(rDest)

【讨论】：

抱歉，但您必须带我走过这里。这段代码将如何加速循环？
是的，对不起，我的浏览器只显示了查询的顶部。直到我稍后检查...我会考虑将查找 ID 缓存在脚本字典中。所以基本上你为每个数据集键创建一个条目。查找将是键，行将是项目。然后，您将迭代循环，并为字典中的每个 id 使用 Exists 函数在另一个字典中找到它，并检索匹配项以确定要复制的行。这样你就不会通过比访问字典慢的对象模型。

【解决方案2】：

我找到了解决办法。使用循环将行数据粘贴到数组中实际上非常快。整个宏运行大约需要 500 万，而原始代码则需要 3000 多万。

这里的技巧是将 300,000 行分成 25,000 行的较小块，以避免“内存不足”错误。

这是代码，也许它会对某人有所帮助。

Sub DataRetrieval()
'This macro retrieves the Database data of defaulted companies.

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'VARIABLE DECLARATION
'Worksheets
Dim wsSource As Worksheet
Set wsSource = Sheets("Data Retrieval - Source")
Dim wsDestination As Worksheet
Set wsDestination = Sheets("Data Retrieval - Destination")
Dim wsDefaultList As Worksheet
Set wsDefaultList = Sheets("Default List")

'Core ID
Dim CoreIDSource As Long 'Core ID number of the sheet Data Retrieval - Source
Dim CoreIDModel As Long 'Core ID number of the sheet Model
Dim ComparingCoreID As Variant

'Count
Dim RowCountSource As Long 'Count the rows of the sheet Data Retrieval - Source
Dim RowCountDestination As Long 'Count the rows of the sheet Data Retrieval (destination)
RowCountDestination = 0
Dim ColumnCountDestination As Byte

'Tables
Dim TableSource() 'Dynamic table that will store data retrieved from Database
Erase TableSource 'Empty memory to avoid execution issues in case the program breaks before completion
'(tables also erased at the end)
Dim TableDestination(50000, 49) 'Table that will store the data from TableSource. Can store up to 50 columns
Erase TableDestination
Dim TableCoreID() 'Table that will store the list of revised CoreID
TableCoreID = wsDefaultList.Range("B5:B2000") 'First number is 1, not zero. The table is defined like that to avoid
'issues if one of the Core ID is blank (in that case, a table defined dynamically would stop at the blank cell)

'FORMATTING DESTINATION SHEET
'Preparing sheet Data Retrieval (destination)
wsDestination.Range("A3:CC500000").ClearContents

'Copy header
wsSource.Rows(3).Copy
wsDestination.Rows(3).PasteSpecial xlPasteValues

'Format header
With wsDestination.Rows(3)
    .NumberFormat = "@"
    .VerticalAlignment = xlCenter
    .HorizontalAlignment = xlRight
    With .Font
        .Name = "Arial"
        .FontStyle = "Bold"
        .Size = 8
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorDark1
    End With
    With .Interior
        .ThemeColor = xlThemeColorAccent1
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
End With

'STORING DATA IN TABLEDESTINATION VARIABLE
'25,000 rows
TableSource = wsSource.Range("A4:AX25003") 'First row and column numbers are 1 and not 0
Call LoopRetrieveDefaultData(RowCountSource, TableSource, TableCoreID, ColumnCountDestination, TableDestination, RowCountDestination)

'50,000 rows
TableSource = wsSource.Range("A25004:AX50003") 'First row and column numbers are 1 and not 0
Call LoopRetrieveDefaultData(RowCountSource, TableSource, TableCoreID, ColumnCountDestination, TableDestination, RowCountDestination)

'75,000 rows
TableSource = wsSource.Range("A50004:AX75003") 'First row and column numbers are 1 and not 0
Call LoopRetrieveDefaultData(RowCountSource, TableSource, TableCoreID, ColumnCountDestination, TableDestination, RowCountDestination)

'100,000 rows
TableSource = wsSource.Range("A75004:AX100003") 'First row and column numbers are 1 and not 0
Call LoopRetrieveDefaultData(RowCountSource, TableSource, TableCoreID, ColumnCountDestination, TableDestination, RowCountDestination)

'125,000 rows
TableSource = wsSource.Range("A100004:AX125003") 'First row and column numbers are 1 and not 0
Call LoopRetrieveDefaultData(RowCountSource, TableSource, TableCoreID, ColumnCountDestination, TableDestination, RowCountDestination)

'150,000 rows
TableSource = wsSource.Range("A125004:AX150003") 'First row and column numbers are 1 and not 0
Call LoopRetrieveDefaultData(RowCountSource, TableSource, TableCoreID, ColumnCountDestination, TableDestination, RowCountDestination)

'175,000 rows
TableSource = wsSource.Range("A150004:AX175003") 'First row and column numbers are 1 and not 0
Call LoopRetrieveDefaultData(RowCountSource, TableSource, TableCoreID, ColumnCountDestination, TableDestination, RowCountDestination)

'200,000 rows
TableSource = wsSource.Range("A175004:AX200003") 'First row and column numbers are 1 and not 0
Call LoopRetrieveDefaultData(RowCountSource, TableSource, TableCoreID, ColumnCountDestination, TableDestination, RowCountDestination)

'225,000 rows
TableSource = wsSource.Range("A200004:AX225003") 'First row and column numbers are 1 and not 0
Call LoopRetrieveDefaultData(RowCountSource, TableSource, TableCoreID, ColumnCountDestination, TableDestination, RowCountDestination)

'250,000 rows
TableSource = wsSource.Range("A225004:AX250003") 'First row and column numbers are 1 and not 0
Call LoopRetrieveDefaultData(RowCountSource, TableSource, TableCoreID, ColumnCountDestination, TableDestination, RowCountDestination)

'275,000 rows
TableSource = wsSource.Range("A250004:AX275003") 'First row and column numbers are 1 and not 0
Call LoopRetrieveDefaultData(RowCountSource, TableSource, TableCoreID, ColumnCountDestination, TableDestination, RowCountDestination)

'300,000 rows
TableSource = wsSource.Range("A275004:AX300003") 'First row and column numbers are 1 and not 0
Call LoopRetrieveDefaultData(RowCountSource, TableSource, TableCoreID, ColumnCountDestination, TableDestination, RowCountDestination)

'325,000 rows
TableSource = wsSource.Range("A300004:AX325003") 'First row and column numbers are 1 and not 0
Call LoopRetrieveDefaultData(RowCountSource, TableSource, TableCoreID, ColumnCountDestination, TableDestination, RowCountDestination)

'350,000 rows
TableSource = wsSource.Range("A325004:AX350003") 'First row and column numbers are 1 and not 0
Call LoopRetrieveDefaultData(RowCountSource, TableSource, TableCoreID, ColumnCountDestination, TableDestination, RowCountDestination)

'375,000 rows
TableSource = wsSource.Range("A350004:AX375003") 'First row and column numbers are 1 and not 0
Call LoopRetrieveDefaultData(RowCountSource, TableSource, TableCoreID, ColumnCountDestination, TableDestination, RowCountDestination)

'400,000 rows
TableSource = wsSource.Range("A375004:AX400003") 'First row and column numbers are 1 and not 0
Call LoopRetrieveDefaultData(RowCountSource, TableSource, TableCoreID, ColumnCountDestination, TableDestination, RowCountDestination)

'PASTING DATA IN SHEET DESTINATION AND FORMATTING
'Paste TableSource
wsDestination.Range("A4:AX50004") = TableDestination

'Format pasted area
wsDestination.Select 'The sheet must be activated
wsDestination.Range("A4:AX50004").Select
Call TableRows

wsDestination.Cells.HorizontalAlignment = xlLeft

'Empty memory
Erase TableSource
Erase TableDestination
Erase TableCoreID

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Sub LoopRetrieveDefaultData(RowCountSource As Long, TableSource As Variant, TableCoreID As Variant, ColumnCountDestination As Byte, TableDestination As Variant, RowCountDestination As Long)

For RowCountSource = 1 To 25000
    If IsError(Application.Match(TableSource(RowCountSource, 2), TableCoreID, 0)) = False Then 'Comparing Core ID. The
    'column number is 2 and not 1 because the first column of the table is 1
    'from TableSource (Arrow Bar data) to list of defaults Core ID(TableCoreID)
    For ColumnCountDestination = 0 To 49 'Paste correponding row in TableDestination
        TableDestination(RowCountDestination, ColumnCountDestination) = TableSource(RowCountSource, ColumnCountDestination + 1)
    Next ColumnCountDestination
    RowCountDestination = RowCountDestination + 1
    End If
Next RowCountSource
End Sub

【讨论】：