是否可以在VBA中汇总数组的指定段落？
例如
类似于第3行：如果Flag = 0，则将4加到7
在有连续0的情况下，例如第5行和第6行：求和（10，20）并将结果加到第4行的5
我唯一的解决方案是
using search(direction=xlnext) on Flag column Flag=0
arr(i)=activecell.row
using search(direction=xlnext) on Flag column Flag=1
brr(j)=activecell.row
我可以用arr(i),brr(j)来总结给定Flag列= 0的数字，但是
有更好的解决方案吗？
| Given | Flag | Result |
|-------|------|--------|
| 2 | 1 | 2 |
| 3 | 1 | 7 |
| 4 | 0 | 0 |
| 5 | 1 | 35 |
| 10 | 0 | 0 |
| 20 | 0 | 0 |
答案 0 :(得分：0)
对不起，没有时间发布阵列版本。
Sub SelCalcWriteArray()
'To make it work you at least have to select all the data in column1.
Dim oRng As Range
Dim oRngTemp As Range 'Temporary Range (Column3)
Dim loF1 As Long 'Row Counter
Dim loInitial As Long 'Initial Values (Column1)
Dim iFlag As Integer 'Flag (Column2)
Dim loTemp As Long 'Temporary Sum
Set oRng = Selection
For loF1 = 1 To oRng.Rows.Count
loInitial = oRng.Cells(loF1, 1)
iFlag = oRng.Cells(loF1, 2)
If iFlag = 1 Then
If loF1 <> 1 Then 'The First run-throug skips this code.
' The value of the the temporary sum variable is written to a cell in column3.
oRngTemp.Value = loTemp
End If
' The cell in column3 is assigned to a temporary range.
Set oRngTemp = oRng.Cells(loF1, 3)
' The value in column1 is added to the temporary sum variable.
loTemp = loInitial '* iFlag
Else
' The value 0 is added in the cell column3
oRng.Cells(loF1, 3) = 0
' The temporary variable is increased by the value of the cell in column1.
loTemp = loTemp + oRng.Cells(loF1, 1).Value
End If
Next
' The last value of the the temporary sum variable is written to a cell in
' column3.
If oRngTemp.Rows <> oRng.Rows.Count Then
oRngTemp.Value = loTemp
End If
End Sub
答案 1 :(得分：0)
Sub SelCalcWriteArray()
'To make it work you at least have to select all the data in column1.
Dim oRng As Range
Dim loF1 As Long 'Row Counter
Dim loTemp As Long 'Temporary Sum
Dim lo2 As Long 'Non-Zero Counter
Set oRng = Selection
'Loop through all rows
For loF1 = 1 To oRng.Rows.Count
'Flag = 1
If oRng.Cells(loF1, 2) = 1 Then
'Add to initial value to the temporary sum variable
loTemp = oRng.Cells(loF1, 1)
'Count the number of non-zero flag values
lo2 = 1
'Check for flag value in next entry
Do Until oRng.Cells(loF1 + lo2, 2) <> 0
'Check if the sum of the entry counter and the non-zero counter is
'greater than the the number of rows
If loF1 + lo2 > oRng.Rows.Count Then Exit Do
'Increase the temporary sum variable
loTemp = loTemp + oRng.Cells(loF1 + lo2, 1)
'Increase the non-zeri flag count
lo2 = lo2 + 1
Loop
oRng.Cells(loF1, 3) = loTemp
Else
'Flag = 0
oRng.Cells(loF1, 3) = 0
End If
Next
End Sub
更多数据
-----------
I F R
-----------
2 1 2
3 1 7
4 0 0
5 1 35
10 0 0
20 0 0
2 1 2
16 1 43
19 0 0
3 0 0
5 0 0
7 1 15
8 0 0
16 1 16
5 1 5
19 1 19
19 1 39
20 0 0
1 1 1
17 1 17
答案 2 :(得分：0)
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