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

Question

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

Dim byteArray As Byte() = System.IO.File.ReadAllBytes(chemin)

对于任何俱乐部，他们可能会在稍后添加多个帐户展示位置，与上面的相应列对齐。我的目标是计算每个俱乐部的总计，这将自动计入俱乐部下的所有账户安置，计算如下：

EG。俱乐部B的总数=账户安置的价值1 +账户安置的价值2 + ......

与其他俱乐部一样。我已设法使用以下代码找到每个俱乐部和第一个帐户的价值：

    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:    ##

以上代码找到＆＃34;帐户放置＆＃34;水平的，即。它将获得俱乐部A的第一个值，然后是俱乐部B的第一个值，然后是俱乐部C的第一个值，然后是俱乐部B的第二个值，然后是俱乐部D等的第一个值，与上述工作表布局相关。

这使得很难获得每个俱乐部的价值总和。你是如何解决这个问题的？任何帮助表示赞赏。

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”关键字时才会通过简单计算来检查。此外，单元格指针不会递增1，而是跳转到下一个非空单元格。

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

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