1

我有一个数据集，其中包含源文件中不同范围的数据，我想将其组合成一个范围并复制/粘贴到目标文件中。虽然联合工作，但我需要在一百个工作表上运行它，而且联合/复制/粘贴花费的时间太长。我想看看我是否会通过转换为数组来提高性能。

我已经尝试通过使用联合来组合范围来这样做，但是我无法让数组在这样做时初始化为多于一列。不知道我做错了什么？

这是一个例子。

sub CopyData()
dim LastR as long
dim dataArr as variant

with SourceWS
    LastR = .cells(.rows.count,1).end(xlup).row

    dataArr = .union(.range("A8:A" & LastR), _
                     .range("C8:C" & LastR), _
                     .range("H8:H" & LastR))

end with

DestWS.range("A1").resize(ubound(dataArr,1), ubound(dataArr,2)) = dataArr

end sub
4

3 回答 3

2

我在另一个论坛上收到了一些帮助。以下完成了我正在尝试做的事情：

Sub CombineRanges()

    Dim MyArr() As Variant
    Dim MyRows as Variant

    MyRows = Evaluate("ROW(1:20)")
    MyArr = Application.Index(Columns("A:H"), MyRows, Array(1, 3, 8))
    Range("Z1").Resize(UBound(MyArr, 1), UBound(MyArr, 2)).Value2 = MyArr

End Sub
于 2021-11-13T21:16:33.870 回答
1

A)部分中的方法双零索引是作为对您自己答案的回复，目的是展示另一个相对未知的变化，Application.WorksheetFunction.Index()并专注于您的初始Union范围。

但是，如果您处理 MS 365 的较新动态数组功能，您可以在B) 灵活工作表相关评估部分 （截至 2021 年 11 月 18 日的后期发布）中找到一种快速、灵活且直接的方法。

A) 双零索引

您发布了一个解决方案，该解决方案创建了一个出色的数据字段数组，其中包括许多不需要的列，您可以通过Application.Index()仅将列号保留在Array(1,3,8). 您可能会对我 3 年前写的一些特性的概述感兴趣。Application.Index()

您可以从发布的联合范围开始执行相反的操作，而不是从数据字段数组中删除所有不需要的列：

  • 仅在所谓的锯齿状数组（又名数组数组或数组容器）中收集现有 区域数据（假定长度相同的单列）和
  • 通过 - 将所有内容统一到一个连贯的 2-dim 数组Application.Index(data, 0, 0)- 请注意这里的双零参数！
Option Explicit

Sub CopyData()
'Site: https://stackoverflow.com/questions/69951489/how-can-i-add-different-ranges-to-an-array
'Note: needs identical number of elements in each area of one column!
'[0]build example Union range as in original post
    With Sheet1               ' change as needed
        Dim lastR As Long
        lastR = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim u As Range
        Set u = Union(.Range("A8:A" & lastR), _
                      .Range("C8:C" & lastR), _
                      .Range("H8:H" & lastR))
    End With

'[1]assign "flat" (transposed) column data to a jagged array (array container)
    Dim data
    With Application.WorksheetFunction     ' preferrable inst/of Application only
        data = Array(.Transpose(u.Areas(1)), .Transpose(u.Areas(2)), Application.Transpose(u.Areas(3)))
    End With
'[2]unite data as 2-dim array
    data = Application.Transpose(Application.Index(data, 0, 0))
'[3]write to any target (e.g. Sheet2)
    Sheet2.Range("A1").Resize(UBound(data, 1), UBound(data, 2)) = data
End Sub

警告

请注意，由于 vers。Application.WorksheetFunction.Transpose如果应用于范围，则2016 转置克服了 65536 (2 ^ 16) 的限制；不幸的是，如果应用于数组，它保持不变。

B) 灵活的工作表相关评估 //（添加于 2021-11-18）

基于版本 MS 365 的快速方法

与A) 部分一样，我假设不相邻的单列。主要逻辑在于构建的公式字符串能够按照初始Union范围定义的顺序获取 2-dim 数组。在您的示例中，区域数量（表示为数组）和区域地址可能会导致类似

    =LET(data,CHOOSE({1,2,3},A8:A20,C8:C20,H8:H20),data)

其中CHOOSEvia反映了在对 a{1,2,3}进行另一次评估之后列出的列的所需顺序。ARRAYTOTEXTSEQUENCE


Sub CopyDataNew()
    Dim t As Double: t = Timer
'[0]build example Union range as in original post
    With Sheet1               ' change as needed
        Dim lastR As Long
        lastR = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim u As Range
        Set u = Union(.Range("A8:A" & lastR), _
                      .Range("C8:C" & lastR), _
                      .Range("H8:H" & lastR))
'[1]a) get sequence string, e.g. "{1,2,3}" (note "."-prefix of .Evaluate!)
    Dim arrText As String
    arrText = .Evaluate("ARRAYTOTEXT(SEQUENCE(1," & u.Areas.Count & ",1),1)")
'[1]b) get formula string,
    Dim myFormula As String
    myFormula = "=LET(data,CHOOSE(" & arrText & "," & u.Address(False, False) & "),data)"
    Debug.Print myFormula
'[1]c) execute worksheet related evaluation (fully qualifying union addresses)
    Dim data
    data = .Evaluate(myFormula)
'[2]write to any target range
    With Sheet2                  
    .Range("A2").Resize(UBound(data, 1), UBound(data, 2)) = data
''   or enter formula into sheet to display as spill range
'    .Range("A2").Formula2 = myFormula
    End With
    
    Debug.Print Format(Timer - t, "0.00 secs needed!")

End Sub

提示与工作表相关的评估- 例如Sheet1.Evaluate(myFormula)- 具有任何内部范围引用自动完全限定的优点。

于 2021-11-14T20:06:03.180 回答
0

获取范围列

  • 这只是对 OP答案RowsArray的研究，它比呈现的更复杂 ( )。功能GetRangeColumns是从中拿走的东西。
  • 测试程序应该消除关于如何使用该功能的任何混淆。测试过程是为包含此代码的工作簿编写的，两个工作表都位于其中（源工作簿和目标工作簿相同）。因此，需要进行一些更改以使其适应循环使用（多个源工作簿，一个目标工作簿）。
Option Explicit

Sub GetRangeColumnsTEST()
' Needs 'GetRangeColumns'.
    Const ProcTitle As String = "Get Range Columns Test"
    
    ' Source
    Const sName As String = "Sheet1"
    Const sCols As String = "A:H"
    Const slrCol As String = "A"
    Const sfRow As Long = 8
    Dim iCols As Variant: iCols = Array(1, 3, 8)
    ' By using e.g. 'iCols = Array(1, 3, 8, 4, 3)' it is proven that the order
    ' of the columns doesn't matter ('4') and that you can repeat columns ('3').
    ' Destination
    Const dName As String = "Sheet2"
    Const dFirst As String = "A2"
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, slrCol).End(xlUp).Row
    If slRow < sfRow Then Exit Sub ' no data in column range
    Dim scrg As Range: Set scrg = sws.Columns(sCols)
    
    ' Array
    Dim Data As Variant: Data = GetRangeColumns(scrg, sfRow, slRow, iCols)
    If IsEmpty(Data) Then Exit Sub ' see message in the Immediate window.
    
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dfCell As Range: Set dfCell = dws.Range(dFirst)
    Dim drg As Range: Set drg = dfCell.Resize(UBound(Data, 1), UBound(Data, 2))
    drg.Value = Data
    
    ' Information
    MsgBox "Columns written.", vbInformation, ProcTitle

End Sub

Function GetRangeColumns( _
    ByVal ColumnsRange As Range, _
    ByVal FirstRow As Long, _
    ByVal LastRow As Long, _
    ByVal ColumnsArray As Variant) _
As Variant
    Const ProcName As String = "GetRangeColumns"
    On Error GoTo ClearError

    Dim RowsArray As Variant
    RowsArray = Evaluate("ROW(" & FirstRow & ":" & LastRow & ")")
    GetRangeColumns _
        = Application.Index(ColumnsRange, RowsArray, ColumnsArray)

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Function
于 2021-11-15T04:11:08.987 回答