从2张纸中填充1-D阵列（无循环）

Question

目标：从2列（在2个不同的文件中）填充一维数组，而无需循环。

我试图将第一个列表读取到数组的代码在行上失败

MergeAccountOpportArr = NamesRng.Value 

尝试输入的代码：

Option Explicit

Public AccountsWB                   As Workbook
Public AccountsSht                  As Worksheet

' --- Columns Variables  ---
Public Const NamesCol          As String = "F"

' --- Public Arrays ---
Public MergeAccountOpportArr()     As String

'===================================================================

Sub MergeRangestoArray()

Dim OpportWBName As String, AccountsWBName As String, WebinarWBName As String
Dim NamesRng As Rang
Dim LastRow As Long, i As Long

ReDim MergeAccountOpportArr(100000) 'init size array to very large size >> will optimize later

' open Accounts file
AccountsWBName = GetFileName(ThisWorkbook.Path, "Accounts")

' set the Accounts file workbook object
Set AccountsWB = Workbooks.Open(Filename:=AccountsWBName, ReadOnly:=True)

' set the worksheet object
Set AccountsSht = AccountsWB.Worksheets(1)

With AccountsSht
    LastRow = FindLastRow(AccountsSht) ' get last row
    Set NamesRng = .Range(.Cells(1, NamesCol), .Cells(LastRow, NamesCol))

    MergeAccountOpportArr = NamesRng.Value ' <---- Here comes the error
End With

' rest of my code

End Sub

Answer 1

这会将范围转换为由指定字符分隔的字符串。然后，它将两个列表通过split（）连接到一个数组中

注意：

• 分隔符必须是数据集中没有的字符

• 转置是由于您的数据在列中。如果您的数据为行，则必须对其进行检查，也许要使用诸如列数之类的方法。

。

Sub Test()
    Dim oResultArray() As String
    oResultArray = MergeRngToArray(Sheet1.Range("B3:B12"), Sheet2.Range("B2:B6"))
End Sub

Private Function MergeRngToArray(ByVal Range1 As Range, ByVal Range2 As Range, Optional Delimiter As String = ",") As String()
    Dim sRange1 As String
    Dim sRange2 As String

    sRange1 = Join(Application.WorksheetFunction.Transpose(Range1.Value), Delimiter) & Delimiter
    sRange2 = Join(Application.WorksheetFunction.Transpose(Range2.Value), Delimiter)

    MergeRngToArray = Split(sRange1 & sRange2, Delimiter)

End Function

Answer 2

从理论上讲，您应该可以通过破解内存中的SAFEARRAY结构来做到这一点。 SAFEARRAY的数据区域的索引由各个维度的索引的乘积确定，因此，如果您有一个二维数组，其中一个维度仅包含一个元素，则一维的内存地址应该相同数组（行* 1 =行）。

---

作为概念证明...

您可以在家中尝试此功能，但这不是生产等级代码。

'In declarations section:
#If VBA7 Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias _
        "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, _
        ByVal length As Long)
#Else
    Private Declare Sub CopyMemory Lib "kernel32" Alias _
        "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, _
        ByVal length As Long)
#End If

Private Const VT_BY_REF = &H4000&

Private Type SafeBound
    cElements As Long
    lLbound As Long
End Type

Private Type SafeArray
    cDim As Integer
    fFeature As Integer
    cbElements As Long
    cLocks As Long
    #If VBA7 Then
        pvData As LongPtr
    #Else
        pvData As Long
    #End If
    rgsabound As SafeBound
    rgsabound2 As SafeBound
End Type

---

Public Function RangeToOneDimensionalArray(Target As Range) As Variant()
    If Target.Columns.Count > 1 Or Target.Rows.Count = 1 Then
        Err.Raise 5 'Invalid procedure call or argument
    End If

    Dim values() As Variant
    values = Target.Value

    If HackDimensions(values) Then
        RangeToOneDimensionalArray = values
    End If
End Function

Private Function HackDimensions(SafeArray As Variant) As Boolean
    Dim vtype As Integer
    'First 2 bytes are the VARENUM.
    CopyMemory vtype, SafeArray, 2
    Dim lp As Long
    'Get the data pointer.
    CopyMemory lp, ByVal VarPtr(SafeArray) + 8, 4
    'Make sure the VARENUM is a pointer.
    If (vtype And VT_BY_REF) <> 0 Then
        'Dereference it for the actual data address.
        CopyMemory lp, ByVal lp, 4
        Dim victim As SafeArray
        CopyMemory ByVal VarPtr(victim), ByVal lp, LenB(victim)
        'Set the dimensions to 1
        victim.cDim = 1
        'Set the bound on the first dimension.
        victim.rgsabound.cElements = victim.rgsabound2.cElements
        CopyMemory ByVal lp, ByVal VarPtr(victim), LenB(victim)
        HackDimensions = True
    End If
End Function

请注意，这必须交换2维（并且声明仅限于2D数组）。它还使第二维rgsabound处于“挂起”状态，因此，每次运行此结构时，您很可能会泄漏该结构的内存（8个字节）。

更安全的方法是将内存区域的内容复制到一个新的一维数组中，并使用它代替， OR 将整个混乱包裹在Class模块中，并在您自己清理之后完成。

---

哦，是的；-）

Public Sub Testing()
    Dim sample() As Variant
    sample = RangeToOneDimensionalArray(Sheet1.Range("A1:A30"))

    Dim idx As Long
    For idx = 1 To 30
        Debug.Print sample(idx)
    Next
End Sub

Answer 3

首先要解决将单元格复制到一维数组中的问题

您可以使用以下技巧轻松地从一维数组转到一个范围：

Public Sub TESTING()

    Dim keyarr() As Variant

    keyarr = Array("1", "2", "3", "4", "5")

    Range("D3").Resize(5, 1).Value = WorksheetFunction.Transpose(keyarr)

End Sub

但相反要困难得多，因为范围的.Value属性始终返回2D数组。

与移调功能一起使用时除外：

Public Sub TESTING()

    Dim i As Long, n As Long
    Dim keyarr() As Variant

    n = Range(Range("B3"), Range("B3").End(xlDown)).Rows.Count

    keyarr = WorksheetFunction.Transpose(Range("B3").Resize(n, 1).Value)
    ' keyarr is a n×1 1D array

    ' Proof:
    For i = 1 To n
        Debug.Print keyarr(i)
    Next i

End Sub

诀窍是：a）使用.Transpose()函数将一列变成一行，并b）使用Variant而不是String的数组。数组内部将存储字符串，但是类型必须为 Variant。

现在最后一个问题是合并两个数组

我唯一想到的解决方案是将数据合并到另一个工作表中。

Public Sub TESTING()

    Dim i As Long, n1 As Long, n2 As Long
    Dim vals1() As Variant, vals2() As Variant

    ' Pull two sets of data from two columns. You could use different sheets if you wanted.
    n1 = Range(Range("B3"), Range("B3").End(xlDown)).Rows.Count
    vals1 = WorksheetFunction.Transpose(Range("B3").Resize(n1, 1).Value)

    n2 = Range(Range("D3"), Range("D3").End(xlDown)).Rows.Count
    vals2 = WorksheetFunction.Transpose(Range("D3").Resize(n2, 1).Value)

    Sheet2.Range("A1").Resize(n1, 1).Value = WorksheetFunction.Transpose(vals1)
    Sheet2.Range("A1").Offset(n1, 0).Resize(n2, 1).Value = WorksheetFunction.Transpose(vals2)

    Dim keyarr() As Variant
    keyarr = WorksheetFunction.Transpose(Sheet2.Range("A1").Resize(n1 + n2, 1).Value)


End Sub

Answer 4

数组方法

Sub JoinColumnArrays(a, b)
'Purpose: join 2 vertical 1-based 2-dim datafield arrays based on two range columns
'Note:    returns 2-dim array with only 1 column
'Hint:    overcomes ReDim Preserve restriction to change only the last dimension!         
a = Application.Index(a, Evaluate("row(1:" & UBound(a) + UBound(b) & ")"), 0)
Dim i As Long, Start As Long: Start = UBound(a) - UBound(b)
For i = 1 To UBound(b)
    a(Start + i, 1) = b(i, 1)        ' fills empty a elements with b elements
Next i
End Sub

上面的数组方法返回一个基于1的2维数组（只有1个“列”作为第二维），其UBound(a)值已更改，即数组{{ 1}}加上数组a的元素计数。

请注意，使用b函数克服了Application.Index()的限制，该限制只会更改数组的最后一个维度。

示例呼叫

ReDim Preserve