最终解决方案
Sub SelCalcWriteArray3()
'Description
' In a two column selection uses the entries as arguments for a function and
' writes the results of the function into the adjacent third column.
Dim TheArray As Variant
Dim loArr As Long 'ForNext Row Counter, Array Rows Counter
Dim iArr As Integer 'Array Column Counter
Dim loTemp As Long 'Temporary Sum Variable
Dim loNonZero As Long 'Non-Zero Counter
Dim str1 As String 'Debug String Variable
With Application
'Restrict the Selection to two adjacent columns only.
If .Selection.Areas.Count <> 1 Or _
.Selection.Columns.Count <> 2 Then GoTo SelectionErr
'Assign the Selection's values to an array.
TheArray = .Selection
End With
' str1 = "Initial Contents of the Array"
' For loArr = LBound(TheArray, 1) To UBound(TheArray, 1)
' For iArr = LBound(TheArray, 2) To UBound(TheArray, 2)
' If iArr > 1 Then
' str1 = str1 & Chr(9) & TheArray(loArr, iArr)
' Else
' str1 = str1 & vbCrLf & TheArray(loArr, iArr)
' End If
' Next
' Next
' Debug.Print str1
'Remarks
'The first dimension of the array is referred to as rows, and the second
'one as columns in this code's comments.
''''''''''''''''''''''''''''''''''''''''
'Status: The initial array contains 2 columns of data copied from the Selection.
''''''''''''''''''''''''''''''''''''''''
'Add a new (third) column (second dimension) to the array for the results
'indicated by '+ 1)' at the end of the following line. Preserve the initial
'data.
ReDim Preserve TheArray(1 To UBound(TheArray), 1 To UBound(TheArray, 2) + 1)
'Loop through all rows.
For loArr = LBound(TheArray) To UBound(TheArray)
'Check non-zero flag value
If TheArray(loArr, 2) = 1 Then 'Flag=1
'Add initial value to the temporary sum variable.
loTemp = TheArray(loArr, 1)
'Initiate the non-zero flag values counter.
loNonZero = loArr + 1
'Check if the non-zero flag counter is greater than the the number of
'rows.
If loNonZero < UBound(TheArray) Then 'It IS NOT the last row (for sure).
'Check for flag value in the next row.
Do Until TheArray(loNonZero, 2) <> 0
'Increase the temporary sum variable.
loTemp = loTemp + TheArray(loNonZero, 1)
'Increase the non-zeri flag counter.
loNonZero = loNonZero + 1
'Check if it is the last row.
If loNonZero = UBound(TheArray) Then Exit Do 'It IS the last row.
Loop
End If
Else 'Flag = 0
loTemp = 0
End If
'Finally write to the third (new) column.
TheArray(loArr, 3) = loTemp
Next
' str1 = "Resulting contents of the Array"
' For loArr = LBound(TheArray, 1) To UBound(TheArray, 1)
' For iArr = LBound(TheArray, 2) To UBound(TheArray, 2)
' If iArr > 1 Then
' str1 = str1 & Chr(9) & TheArray(loArr, iArr)
' Else
' str1 = str1 & vbCrLf & TheArray(loArr, iArr)
' End If
' Next
' Next
' Debug.Print str1
''''''''''''''''''''''''''''''''''''''''
'Status: The resulting array is populated with all the data i.e.
' the initial data (columns 1 and 2) and the new data (column 3).
''''''''''''''''''''''''''''''''''''''''
'Output
'Paste the third (adjacent) column into the worksheet by introducing another
'array (SmallArray) containing only the third column of the array (TheArray).
Dim SmallArray As Variant
Dim oRng As Range
'A one-based array is needed to be pasted into the worksheet via range.
ReDim SmallArray(LBound(TheArray) To UBound(TheArray), 1 To 1)
For loArr = LBound(TheArray) To UBound(TheArray)
SmallArray(loArr, 1) = TheArray(loArr, 3)
Next
Set oRng = Range(Selection(1, UBound(TheArray, 2)).Address & ":" _
& Selection(UBound(TheArray), UBound(TheArray, 2)).Address)
oRng = SmallArray
'Output is 2,5 times faster than Output2, and 50 times faster than Output3.
'Output2
' 'Paste the complete array into a range (selection (two columns) + third
' 'column) overwriting the initial data (with the same data).
' Dim oRng As Range
' Set oRng = Range(Selection(1, 1).Address & ":" _
' & Selection(UBound(TheArray), UBound(TheArray, 2)).Address)
' oRng = TheArray
' 'Output2 is 20 times faster than Output3.
'Output3
' 'Write to the third (adjacent) column to the worksheet by looping through the
' 'third column of the array.
' For loArr = LBound(TheArray) To UBound(TheArray)
' Selection(loArr, 3) = TheArray(loArr, 3)
' Next
'Remarks
'The output execution times were measured using Excel 2003 selecting 50.000 rows
'of data resulting in 0.08, 0.2 and 4.4 seconds. At 10.000 rows all three ways
'would be below a second.
''''''''''''''''''''''''''''''''''''''''
'Status: The resulting third column in the array has been pasted into the
' column adjacent to the initial 2 columns in the worksheet.
''''''''''''''''''''''''''''''''''''''''
Exit Sub
SelectionErr:
MsgBox "You have to select data in two adjacent columns!", _
vbInformation + vbDefaultButton1 + vbMsgBoxHelpButton, _
"Preventing Array Error (Type Mismatch)", _
"C:\PROGRA~1\COMMON~1\MICROS~1\VBA\VBA6\1033\VbLR6.chm", 1000013
End Sub