Excel VBA -如何从动态范围内重复固定间隔的单元格值

Question

我有一个Excel工作表，其格式如下：

    Club A  Total:    ##        Club B  Total:    ##         Club C   Total:    ##
            Account Placement           Account Placement             Account Placement
            Value:    ##                Value:    ##                  Value:    ##

                                        Account Placement
                                        Value:    ##

    Club D  Total:    ##        Club E  Total:    ##         Club F  Total:     ##
            Account Placement           Account Placement            Account Placement
            Value:    ##                Value:    ##                 Value:    ##      

            Account Placement 
            Value:    ##

            Account Placement 
            Value:    ##

对于任何俱乐部，他们可能有多个帐户的安置后添加，对齐相应的列如上面。我的目标是计算每个俱乐部的总数，它将自动核算一个俱乐部下的所有帐户安排，计算如下：

例如：. Club =‘Club 1’>帐户安置价值1+帐户放置价值2+.

其他俱乐部也是如此。我使用以下代码成功地找到了每个俱乐部和第一个帐户的值：

Dim ra As Range 
For Each ra In ActiveSheet.UsedRange
    If InStr(1, ra.Text, "Account Placement") > 0 Then
        accvalue = Cells(ra.Row + 1, ra.Column + 1).Value
    End If
Next ra

上述代码水平查找“帐户放置”，即。根据上述图解的工作表布局，它将得到A俱乐部的1值、B俱乐部的1值、C俱乐部的1值、B俱乐部的2值、D俱乐部的1值等。

这使得很难得到每个俱乐部的价值之和。你怎样才能解决这个问题？任何帮助都是非常感谢的。

Answer 1

是。诀窍是从上往下扫描，而不是从左到右：

Option Explicit

Sub GetAllTotals2()
    Dim dict
    Set dict = CreateObject("Scripting.Dictionary")
    Dim c As Range, UL As Range
    Dim ID As String, nextID As String
    Dim lastcol As Long, lastrow As Long, v As Long


    With ActiveSheet.UsedRange
        Set UL = .Cells(1, 1)
        Set c = .Cells(1, 1)
        lastcol = UL.Column + .Columns.Count
        lastrow = UL.Row + .Rows.Count
    End With

    ID = ""
    While c.Column < lastcol
        Set c = Cells(UL.Row, c.Column + 1) ' top of column
        'check if column empty
        If c.End(xlDown).Row < lastrow Then
            ' scan "value" column for values; check for ID change!
            While c.Row <= lastrow
                If Left(c.Text, 5) = "value" Then
                    v = c.Offset(0, 1).Value
                    nextID = c.Offset(-2, -1)
                    ' may check nextID, needs to be "Club x"...
                    If nextID <> "" Then ID = nextID  ' ID changed
                    If dict.Exists(ID) Then
                        dict(ID) = dict(ID) + v
                    Else
                        dict.Add ID, v
                    End If
                    Set c = c.Offset(2, 0)  ' skip next 2
                End If
                Set c = c.Offset(1, 0)  ' row-wise
            Wend
        End If
    Wend

    ' show
    Dim key
    For Each key In dict
        Debug.Print key & " " & (dict(key))
    Next key
End Sub

在性能方面，使用while循环并不是最优的。显示的代码已经跳过空列作为开始。我感谢user1274820的dictionary代码，它非常适合这个任务。

编辑：

在工作代码中，我想到了优化。扫描所有已使用的单元格(加上回溯)会导致最糟糕的性能。下面的代码只在包含"value“关键字的情况下才能自顶向下地扫描列，该关键字通过简单的计数来检查。此外，单元格指针不增加一个，而是跳转到下一个非空单元格.

Sub GetAllTotals3()
    Const keyword As String = "value:" ' got to be EXACT

    Dim dict
    Set dict = CreateObject("Scripting.Dictionary")
    Dim c As Range, UL As Range
    Dim ID As String, nextID As String
    Dim lastcol As Long, lastrow As Long, v As Long

    With ActiveSheet.UsedRange
        Set UL = .Cells(1, 1)
        Set c = .Cells(1, 1)
        lastcol = UL.Column + .Columns.Count
        lastrow = UL.Row + .Rows.Count
    End With

    ID = ""
    While c.Column < lastcol
        ' check if column not empty
        If WorksheetFunction.CountIf(c.EntireColumn, keyword) > 0 Then
            ' scan "value" column for keyword; check for ID change!
            While c.Row <= lastrow
                If c.Text = keyword Then
                    v = c.Offset(0, 1).Value
                    nextID = c.Offset(-2, -1)
                    ' may check nextID, needs to be "Club x"...
                    If nextID <> "" Then ID = nextID  ' ID changed
                    If dict.Exists(ID) Then
                        dict(ID) = dict(ID) + v
                    Else
                        dict.Add ID, v
                    End If
                End If
                  ' optim.: jump down to next filled cell
                Set c = c.End(xlDown)
            Wend
        End If
        ' go right to next column, start at top
        Set c = Cells(UL.Row, c.Column) ' top of column
        Set c = c.End(xlToRight)  ' optim.: jump right to next filled cell
    Wend

    ' show
    Dim key
    For Each key In dict
        Debug.Print key & ": " & (dict(key))
    Next key
End Sub

Answer 2

基于@user1274820的回答，我做了一些调整。

Sub GetAllTotals()
Dim dict
Set dict = CreateObject("Scripting.Dictionary")
Dim ra As Range
Dim rollback As Integer  'Additional variable

For Each ra In ActiveSheet.UsedRange
    If InStr(1, ra.Text, "Account Placement") > 0 Then

        rollback = -1
        'Rolling back number of rows to locate the Club ID
        Do Until ra.Offset(rollback,-1).Value <> ""
            rollback = rollback -1
        Loop

        With ra.Offset(rollback, -1)
            If dict.Exists(.Value) Then                
                dict(.Value) = dict(.Value) + ra.Offset(1, 1).Value
            Else                
                dict.Add .Value, ra.Offset(1, 1).Value
            End If
        End With
    End If
Next ra

Dim c
For Each c In dict
    Debug.Print c & " " & (dict(c))
Next c

End Sub

就像魔法一样，一切都完美无缺。