如何在Excel VBA中切片数组？

我可以在Excel VBA中使用哪些函数来切片数组？

Application.WorksheetFunction.Index(array,row,column)

如果为行或列指定零值,则将获得指定的整个列或行.

例:

Application.WorksheetFunction.Index(array,0,3)

这将为您提供整个第3列.

如果将行和列都指定为非零,那么您将只获得特定元素.获得比完整行或列更小的切片没有简单的方法.

限制:WorksheetFunction.Index如果您使用的是较新版本的Excel ,则可以处理的数组大小有限制.如果array有超过65,536行或65,536列,则会引发"类型不匹配"错误.如果这对您来说是一个问题,那么请看这个更复杂的答案,不受同样的限制.

这是我写的所有我的一维和二维切片的功能:

Public Function GetArraySlice2D(Sarray As Variant, Stype As String, Sindex As Integer, Sstart As Integer, Sfinish As Integer) As Variant

' this function returns a slice of an array, Stype is either row or column
' Sstart is beginning of slice, Sfinish is end of slice (Sfinish = 0 means entire
' row or column is taken), Sindex is the row or column to be sliced
' (NOTE: 1 is always the first row or first column)
' an Sindex value of 0 means that the array is one dimensional 3/20/09 ljr

Dim vtemp() As Variant
Dim i As Integer

On Err GoTo ErrHandler

Select Case Sindex
    Case 0
        If Sfinish - Sstart = UBound(Sarray) - LBound(Sarray) Then
            vtemp = Sarray
        Else
            ReDim vtemp(1 To Sfinish - Sstart + 1)
            For i = 1 To Sfinish - Sstart + 1
                vtemp(i) = Sarray(i + Sstart - 1)
            Next i
        End If
    Case Else
        Select Case Stype
            Case "row"
                If Sfinish = 0 Or (Sstart = LBound(Sarray, 2) And Sfinish = UBound(Sarray, 2)) Then
                    vtemp = Application.WorksheetFunction.Index(Sarray, Sindex, 0)
                Else
                    ReDim vtemp(1 To Sfinish - Sstart + 1)
                    For i = 1 To Sfinish - Sstart + 1
                        vtemp(i) = Sarray(Sindex, i + Sstart - 1)
                    Next i
                End If
            Case "column"
                If Sfinish = 0 Or (Sstart = LBound(Sarray, 1) And Sfinish = UBound(Sarray, 1)) Then
                    vtemp = Application.WorksheetFunction.Index(Sarray, 0, Sindex)
                Else
                    ReDim vtemp(1 To Sfinish - Sstart + 1)
                    For i = 1 To Sfinish - Sstart + 1
                        vtemp(i) = Sarray(i + Sstart - 1, Sindex)
                    Next i
                End If
        End Select
End Select
GetArraySlice2D = vtemp
Exit Function

ErrHandler:
    Dim M As Integer
    M = MsgBox("Bad Array Input", vbOKOnly, "GetArraySlice2D")

End Function

下面是切片Excel变体数组的快速方法.大部分内容都是使用这个优秀网站的信息汇总而成的.http://bytecomb.com/vba-reference/

本质上,目标数组预先构建为空的1d或2d变体,并传递给sub,源数组和元素索引将被切片.由于数组存储在内存中的方式,切片列比行更快,因为内存布局允许复制单个块.

这样做的好处是它可以超出Excel行限制.

Option Explicit

#If Win64 Then
    Public Const PTR_LENGTH As Long = 8
    Public Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
    Public Declare PtrSafe Sub Mem_Copy Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
    Private Declare PtrSafe Function VarPtrArray Lib "VBE7" Alias "VarPtr" (ByRef Var() As Any) As LongPtr
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare PtrSafe Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As Long, ByVal Fill As Byte)
#Else
    Public Const PTR_LENGTH As Long = 4
    Public Declare Function GetTickCount Lib "kernel32" () As Long
    Public Declare Sub Mem_Copy Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
    Private Declare Function VarPtrArray Lib "VBE7" Alias "VarPtr" (ByRef Var() As Any) As LongPtr
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As Long, ByVal Fill As Byte)
#End If

Private Type SAFEARRAYBOUND
    cElements    As Long
    lLbound      As Long
End Type

Private Type SAFEARRAY_VECTOR
    cDims        As Integer
    fFeatures    As Integer
    cbElements   As Long
    cLocks       As Long
    pvData       As LongPtr
    rgsabound(0) As SAFEARRAYBOUND
End Type

Sub SliceColumn(ByVal idx As Long, ByRef arrayToSlice() As Variant, ByRef slicedArray As Variant)
'slicedArray can be passed as a 1d or 2d array
'sliceArray can also be part bound, eg  slicedArray(1 to 100) or slicedArray(10 to 100)
Dim ptrToArrayVar As LongPtr
Dim ptrToSafeArray As LongPtr
Dim ptrToArrayData As LongPtr
Dim ptrToArrayData2 As LongPtr
Dim uSAFEARRAY As SAFEARRAY_VECTOR
Dim ptrCursor As LongPtr
Dim cbElements As Long
Dim atsBound1 As Long
Dim elSize As Long

    'determine bound1 of source array (ie row Count)
    atsBound1 = UBound(arrayToSlice, 1)
    'get pointer to source array Safearray
    ptrToArrayVar = VarPtrArray(arrayToSlice)
    CopyMemory ptrToSafeArray, ByVal ptrToArrayVar, PTR_LENGTH
    CopyMemory uSAFEARRAY, ByVal ptrToSafeArray, LenB(uSAFEARRAY)
    ptrToArrayData = uSAFEARRAY.pvData
    'determine byte size of source elements
    cbElements = uSAFEARRAY.cbElements

    'get pointer to destination array Safearray
    ptrToArrayVar = VarPtr(slicedArray) + 8 'Variant reserves first 8bytes
    CopyMemory ptrToSafeArray, ByVal ptrToArrayVar, PTR_LENGTH
    CopyMemory uSAFEARRAY, ByVal ptrToSafeArray, LenB(uSAFEARRAY)
    ptrToArrayData2 = uSAFEARRAY.pvData

    'determine elements size
    elSize = UBound(slicedArray, 1) - LBound(slicedArray, 1) + 1
    'determine start position of data in source array
    ptrCursor = ptrToArrayData + (((idx - 1) * atsBound1 + LBound(slicedArray, 1) - 1) * cbElements)
    'Copy source array to destination array
    CopyMemory ByVal ptrToArrayData2, ByVal ptrCursor, cbElements * elSize

End Sub

Sub SliceRow(ByVal idx As Long, ByRef arrayToSlice() As Variant, ByRef slicedArray As Variant)
'slicedArray can be passed as a 1d or 2d array
'sliceArray can also be part bound, eg  slicedArray(1 to 100) or slicedArray(10 to 100)
Dim ptrToArrayVar As LongPtr
Dim ptrToSafeArray As LongPtr
Dim ptrToArrayData As LongPtr
Dim ptrToArrayData2 As LongPtr
Dim uSAFEARRAY As SAFEARRAY_VECTOR
Dim ptrCursor As LongPtr
Dim cbElements As Long
Dim atsBound1 As Long
Dim i As Long

    'determine bound1 of source array (ie row Count)
    atsBound1 = UBound(arrayToSlice, 1)
    'get pointer to source array Safearray
    ptrToArrayVar = VarPtrArray(arrayToSlice)
    CopyMemory ptrToSafeArray, ByVal ptrToArrayVar, PTR_LENGTH
    CopyMemory uSAFEARRAY, ByVal ptrToSafeArray, LenB(uSAFEARRAY)
    ptrToArrayData = uSAFEARRAY.pvData
    'determine byte size of source elements
    cbElements = uSAFEARRAY.cbElements

    'get pointer to destination array Safearray
    ptrToArrayVar = VarPtr(slicedArray) + 8 'Variant reserves first 8bytes
    CopyMemory ptrToSafeArray, ByVal ptrToArrayVar, PTR_LENGTH
    CopyMemory uSAFEARRAY, ByVal ptrToSafeArray, LenB(uSAFEARRAY)
    ptrToArrayData2 = uSAFEARRAY.pvData

    ptrCursor = ptrToArrayData + ((idx - 1) * cbElements)
    For i = LBound(slicedArray, 1) To UBound(slicedArray, 1)

        CopyMemory ByVal ptrToArrayData2, ByVal ptrCursor, cbElements
        ptrCursor = ptrCursor + (cbElements * atsBound1)
        ptrToArrayData2 = ptrToArrayData2 + cbElements
    Next i

End Sub

用法示例:

Sub exampleUsage()
Dim sourceArr() As Variant
Dim destArr As Variant
Dim sliceIndex As Long

    On Error GoTo Err:

    sourceArr = Sheet1.Range("A1:D10000").Value2
    sliceIndex = 2 'Slice column 2 / slice row 2

    'Build target array
    ReDim destArr(20 To 10000) '1D array from row 20 to 10000
'    ReDim destArr(1 To 10000) '1D array from row 1 to 10000
'    ReDim destArr(20 To 10000, 1 To 1) '2D array from row 20 to 10000
'    ReDim destArr(1 To 10000, 1 To 1) '2D array from row 1 to 10000

    'Slice Column
    SliceColumn sliceIndex, sourceArr, destArr

    'Slice Row
    ReDim destArr(1 To 4)
    SliceRow sliceIndex, sourceArr, destArr

Err:
    'Tidy Up See ' http://stackoverflow.com/questions/16323776/copy-an-array-reference-in-vba/16343887#16343887
    FillMemory destArr, 16, 0

End Sub

使用以下测试,计时在旧的双核CPU上

Sub timeMethods()
Const trials As Long = 10
Const rowsToCopy As Long = 1048576
Dim rng As Range
Dim Arr() As Variant
Dim newArr As Variant
Dim newArr2 As Variant
Dim t As Long, t1 As Long, t2 As Long, t3 As Long
Dim i As Long

    On Error GoTo Err

    'Setup Conditions 1time only
    Sheet1.Cells.Clear
    Sheet1.Range("A1:D1").Value = Split("A1,B1,C1,D1", ",") 'Strings
'    Sheet1.Range("A1:D1").Value = Split("1,1,1,1", ",") 'Longs
    Sheet1.Range("A1:D1").AutoFill Destination:=Sheet1.Range("A1:D" & rowsToCopy), Type:=xlFillDefault

    'Build source data
    Arr = Sheet1.Range("A1:D" & rowsToCopy).Value
    Set rng = Sheet1.Range("A1:D" & rowsToCopy)

    'Build target container
    ReDim newArr(1 To rowsToCopy)
    Debug.Print "Trials=" & trials & " Rows=" & rowsToCopy
    'Range
    t3 = 0
    For t = 1 To trials
        t1 = GetTickCount

            For i = LBound(newArr, 1) To UBound(newArr, 1)
                newArr(i) = rng(i, 2).Value2
            Next i

        t2 = GetTickCount
        t3 = t3 + (t2 - t1)
        Debug.Print "Range: " & t2 - t1
    Next t
    Debug.Print "Range Avg ms: " & t3 / trials

    'Array
    t3 = 0
    For t = 1 To trials
        t1 = GetTickCount

            For i = LBound(newArr, 1) To UBound(newArr, 1)
                newArr(i) = Arr(i, 2)
            Next i

        t2 = GetTickCount
        t3 = t3 + (t2 - t1)
        Debug.Print "Array: " & t2 - t1
    Next t
    Debug.Print "Array Avg ms: " & t3 / trials

    'Index
    t3 = 0
    For t = 1 To trials
        t1 = GetTickCount

            newArr2 = WorksheetFunction.Index(rng, 0, 2) 'newArr2 2d

        t2 = GetTickCount
        t3 = t3 + (t2 - t1)
        Debug.Print "Index: " & t2 - t1
    Next t
    Debug.Print "Index Avg ms: " & t3 / trials

    'CopyMemBlock
    t3 = 0
    For t = 1 To trials
        t1 = GetTickCount

            SliceColumn 2, Arr, newArr

        t2 = GetTickCount
        t3 = t3 + (t2 - t1)
        Debug.Print "CopyMem: " & t2 - t1
    Next t
    Debug.Print "CopyMem Avg ms: " & t3 / trials

Err:
    'Tidy Up
    FillMemory newArr, 16, 0


End Sub