Welcome to OGeek Q&A Community for programmer and developer-Open, Learning and Share
Welcome To Ask or Share your Answers For Others

Categories

0 votes
816 views
in Technique[技术] by (71.8m points)

vba - Slice array to use index on larger than 65000

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
See Question&Answers more detail:os

与恶龙缠斗过久,自身亦成为恶龙;凝视深渊过久,深渊将回以凝视…
Welcome To Ask or Share your Answers For Others

1 Reply

0 votes
by (71.8m points)

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

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

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

与恶龙缠斗过久,自身亦成为恶龙;凝视深渊过久,深渊将回以凝视…
OGeek|极客中国-欢迎来到极客的世界,一个免费开放的程序员编程交流平台!开放,进步,分享!让技术改变生活,让极客改变未来! Welcome to OGeek Q&A Community for programmer and developer-Open, Learning and Share
Click Here to Ask a Question

...