切片数组使用大于 65000 的索引 [英] Slice array to use index on larger than 65000

问题描述

我使用下面的代码来计算本文中描述的最大值(vba 值组的最大值).代码运行良好，但是一旦我有超过 65k 行，我在尝试传递数组时会遇到数据类型不匹配:

I use the code hereunder to calculate max values as described in this post (vba max value of group of values). The code works great but once I have more than 65k lines I get a data type mismatch when trying to pase the array:

sht.Range(Cells(1, lColumn), Cells(last.Row, lColumn)).Value = Application.Index(groupsArray, , lColumn)

有人能帮我把数组切成块吗?我试图让它自己工作，但没有任何运气.

Could somebody help me to slice the array in chunks. I have tried to get it working myself but without any luck.

    Sub FillGroupsMax()
        Dim lColumn As Long
        Dim sht As Worksheet
        Dim groupsArray As Variant    'array with all group infomation
        Dim groupsSeen As Variant    'array with group infomation already seen

        Application.ScreenUpdating = False    'stop screen updating makes vba perform better

        Set sht = ThisWorkbook.Worksheets("import")
        Set last = sht.Range("A:A").Find("*", Cells(1, 1), searchdirection:=xlPrevious)    'last cell with value in column A
        lColumn = sht.Cells(1, Columns.Count).End(xlToLeft).Column

        groupsArray = sht.Range(Cells(1, 1), Cells(last.Row, lColumn))
        'collect all the information on the Sheet into an array
        'Improves performance by not visiting the sheet

        For dRow = 2 To last.Row    'for each of the rows skipping header

            'check if group as already been seen
            If inArrayValue(Cells(dRow, 1).Value, groupsSeen) > 0 Then
                'if it has been seen/calculated attribute value
                'Cells(dRow, 4).Value = inArrayValue(Cells(dRow, 1).Value, groupsSeen)
                groupsArray(dRow, lColumn) = inArrayValue(Cells(dRow, 1).Value, groupsSeen)
            Else
                'if it hasn't been seen then find max
                'Cells(dRow, 4).Value = getMax(Cells(dRow, 1).Value, groupsArray)
                groupsArray(dRow, lColumn) = getMax(Cells(dRow, 1).Value, groupsArray, lColumn)

                'array construction from empty
                If IsEmpty(groupsSeen) Then
                    ReDim groupsSeen(0)
                    'groupsSeen(0) = Array(Cells(dRow, 1).Value, Cells(dRow, 4).Value)
                    groupsSeen(0) = Array(groupsArray(dRow, 1), groupsArray(dRow, lColumn))
                    'attribute value to array
                Else
                    ReDim Preserve groupsSeen(0 To UBound(groupsSeen) + 1)
                    groupsSeen(UBound(groupsSeen)) = Array(groupsArray(dRow, 1), groupsArray(dRow, lColumn))
                End If
            End If
        Next

    sht.Range(Cells(1, lColumn), Cells(last.Row, lColumn)).Value = Application.Index(groupsArray, , lColumn)
        'reactivate Screen updating
        Application.ScreenUpdating = True

    End Sub

    Function getMax(group As String, groupsArray As Variant, lColumn As Long) As Double

        'for each in array
        For n = 1 To UBound(groupsArray)
            'if its the same group the Max we seen so far the record
            If groupsArray(n, 1) = group And groupsArray(n, lColumn - 1) > maxSoFar Then
                maxSoFar = groupsArray(n, lColumn - 1)
            End If
        Next

        'set function value
        getMax = maxSoFar
    End Function

    Function inArrayValue(group As String, groupsSeen As Variant) As Double

        'set function value
        inArrayValue = 0
        'if array is empty then exit
        If IsEmpty(groupsSeen) Then Exit Function

        'for each in array
        For n = 0 To UBound(groupsSeen)
            'if we find the group
            If groupsSeen(n)(0) = group Then
                'set function value to the Max value already seen
                inArrayValue = groupsSeen(n)(1)
                'exit function earlier
                Exit Function
            End If
        Next

    End Function

推荐答案

你可以写一个辅助函数来代替 Application.Index

You can write a helper function to use instead of Application.Index

奖励 - 比使用 Index (>5x)

Bonus - it will be much faster than using Index (>5x)

Sub Tester()

    Dim arr, arrCol

    arr = Range("A2:J80000").Value

    arrCol = GetColumn(arr, 5) '<< get the fifth column

    Range("L2").Resize(UBound(arrCol, 1), 1).Value = arrCol

End Sub

'extract a single column from a 1-based 2-D array
Function GetColumn(arr, colNumber)
    Dim arrRet, i As Long
    ReDim arrRet(1 To UBound(arr, 1), 1 To 1)
    For i = 1 To UBound(arr, 1)
        arrRet(i, 1) = arr(i, colNumber)
    Next i
    GetColumn = arrRet
End Function

编辑 - 由于 QHarr 询问了时间，这是一个基本示例

EDIT - since QHarr asked about timing here's a basic example

Sub Tester()
    Dim arr, arrCol, t, i as long
    arr = Range("A2:J80000").Value
    t = Timer
    For i = 1 to 100 
        arrCol = GetColumn(arr, 5) '<< get the fifth column
    Next i
    Debug.print Timer - t '<<# of seconds for execution
End Sub

这篇关于切片数组使用大于 65000 的索引的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！