粘贴数组中的行
我一直在尝试几个小时从一个Excel工作表中的VBA数组粘贴一行。
代码应该看起来像这样：
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") = ? 任何想法？
非常感谢您的帮助！
添加了我需要在下面进行优化的原始代码（工作正常）。 正如你所看到的，有将近30万个循环，所以将表格声明为variables会有一定的意义。
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
可能有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)
我find了一个解决scheme。 使用循环将行数据粘贴到数组中实际上是相当快的。 整个macros观运行约需要5百万，而原始代码则需要三千多万。
这里的诀窍是将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