Arrays 有没有一种方法可以在VBA中汇总数组的指定段落

是否有一种方法可以在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

我可以使用arri，brrj来对标志列=0的给定数字求和，但是 有更好的解决办法吗

| Given | Flag | Result |
|-------|------|--------|
| 2     | 1    | 2      |
| 3     | 1    | 7      |
| 4     | 0    | 0      |
| 5     | 1    | 35     |
| 10    | 0    | 0      |
| 20    | 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

更好的方法 最终解决方案

---

欢迎光临！这是一个程序员编写自己的代码并在试图自己解决某个特定问题后共享该问题的网站。请务必查看您将获得的第一枚徽章！如需有关此网站主题的更多信息，请参阅，以及。如果您对代码的某一部分有特定问题，您可以在帖子中共享示例数据和一些背景信息。以下是一些来自该网站的顶级用户。祝你好运你能再详细说明一下这个问题吗？谢谢你的回答。

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 

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