從數組粘貼行

Question

我已經嘗試了幾個小時，將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

Answer 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)

Answer 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