Excel VBA：设置每个循环

编辑：添加下面的原始数据的示例

我每个月都会运行一次索赔报告，并将数据复制到一个标签中。 所有的数据都组织成列，我一直在使用一个电子表格充满了SumProduct和CountIf的计数和组织数据根据不同的标准集，但它只是需要太长的时间来处理，所以我想写一个VBA子来完成这个更高效。 其中一个数据栏是“调节器家庭办公室”。 这一栏基本上是每个索赔起源的办事处清单。 我使用AdvancedFilter来提取此列中的所有唯一值，并将它们复制到列A中的单独的选项卡。然后，在C列中的每个位置下，我有一个索赔types列表或“行项目”在每个办公室。 我没有问题得到这部分设置。 在D列中，我需要能够显示该指定地点的每个订单项的计数。 这就是所有Countif和SumProduct都在我以前使用的旧模板中起作用的地方。 这是我遇到困难的地方。 我正在尝试使用For Each循环来计算第一个位置下方B列中的每个行项目，然后移动到A列中的下一个位置并重复。 以下是我试过的代码：

 Private Sub CommandButton23_Click() Dim linerngs As Range Dim lineitem As Range Dim lastlinerow As Long Dim wsf Dim TabLastRow Dim claimstab As String Dim officesrange As Range Dim office As Range claimstab = Sheet2.Range("F2") & " Claims" TabLastRow = Sheets(claimstab).Cells(Sheets(claimstab).Rows.Count, "A").End(xlUp).Row Set wsf = Application.WorksheetFunction officeslastrow = Sheet2.Range("A" & Rows.Count).End(xlUp).Row lastlinerow = Sheet2.Range("C" & Rows.Count).End(xlUp).Row Set officerng = Range("A6:A" & officeslastrow).SpecialCells(xlCellTypeConstants, 23) Set linerngs = Range("C7:C" & lastlinerow).SpecialCells(xlCellTypeConstants, 23) For Each office In officerng For Each lineitem In linerngs If InStr(1, lineitem.Value, "IN") > 0 And InStr(1, lineitem.Value, "AOS") = 0 Then lineitem.Offset(0, 3) = Application.WorksheetFunction.SumProduct(wsf.CountIfs(Sheets(claimstab).Range("B2:B" & TabLastRow), office)) End If Next lineitem Next office End Sub 

我知道这是不正确的，因为这些循环将遍历B列中的所有内容，而不仅仅是每个位置下面的行项目。 所以我最终得到的是整个列中每个行项目显示的最后一个位置的数量。 下面是我需要它的样子的一个例子。 现在，所有关心的是build立循环正确运行。

我目前得到的例子[

我试图得到的例子[

你可以从第一个例子看到，我得到的值都是“3”。 我包括了地点和他们的价值观的枢纽。 你可以看到，南波特兰枢纽的最后一个位置的计数为3。

任何帮助将不胜感激。

原始数据的例子[

目标[

[ 订单项列表已完成，由用户表单请求用户input

Answer 1

这可能不是你正在寻找的答案，但我认为这是我将如何处理你的项目。 查看报告中的原始数据并将其粘贴到电子表格中会很有帮助。

前两个假设（你知道他们对假设的看法）

1. 数据正在从数据库中提取，并作为可能不正确的行返回。 例如：

  ATLANTA, GA IN-AK, HI 3 IN-CA 2 ... IncidentOnly 4 BOCA RATON, FL IN-AK, HI 3 IN-CA 6 ... IncidentOnly 5 ATLANTA, GA IN-AK, HI 1 IN-CA 0 ... IncidentOnly 2 ... AURORA, IL IN-AK, HI 7 IN-CA 3 ... IncidentOnly 4 

2. 您需要为每个办公室汇总所有保险产品，然后以更漂亮的报告格式显示。

如果这些假设是真实的（或接近真实），您可以创build一个HomeOffice类，该类具有每种保险types的属性，然后简单地遍历原始报表中的数据行，并将每个HomeOffice对象添加到集合中，得到一个独特的办公室名单。

我做了一个类似的testing项目的例子：

 Raw Data: Mary 2 6 Sally 4 9 Mary 4 1 Sally 3 8 Joe 1 4 Bob 3 7 Mary 6 9 Sally 8 4 Bob 4 8 Joe 2 6 Joe 4 5 Formatted Data: Mary 12 16 Sally 15 21 Bob 7 15 Joe 7 15 

为此，添加一个Class模块（Insert – > Class Module）并将其名称更改为HomeOffice。 把这个代码插入到类中（有些位跳过了，所以不用太长时间，在需要的地方填写每个保险产品的属性）。

 Option Explicit Private pOffice As String Private pINAKI As Double Private pINCA As Double '... class properties left out for brevity Private pIncidentOnly As Double '''''''''''''''''''''' ' Office property '''''''''''''''''''''' Public Property Get Office() As String Office = pOffice End Property Public Property Let Office(Value As String) pOffice = Value End Property '''''''''''''''''''''' ' INAKI property '''''''''''''''''''''' Public Property Get INAKI() As Double INAKI = pINAKI End Property Public Property Let INAKI(Value As Double) pINAKI = Value End Property '''''''''''''''''''''' ' INCA property '''''''''''''''''''''' Public Property Get INCA() As Double INCA = pINCA End Property Public Property Let INCA(Value As Double) pINCA = Value End Property '''''''''''''''''''''' ' Add other propertied for the different product types '''''''''''''''''''''' ' Follow the same format as the other properties '''''''''''''''''''''' ' IncidentOnly property '''''''''''''''''''''' Public Property Get IncidentOnly() As Double IncidentOnly = pIncidentOnly End Property Public Property Let IncidentOnly(Value As Double) pIncidentOnly = Value End Property 

现在在你的CommandButton23_Click子文件中添加这个代码（为简洁起见，再次缩短，但希望你能得到图片）：

 Sub test() Dim col As Collection Dim r As Integer Dim c As Integer Dim HO As New HomeOffice 'Collections can only have one Item, Key pair. 'We'll use the office location as the key to get a 'unique list of offices Set col = New Collection 'Read in the raw data With Sheet1 For r = 1 To .UsedRange.Rows.Count 'Check if the location has an existing HomeOffice object If InCol(col, .Cells(r, 1)) Then 'It does so get the existing object and total the values Set HO = col.Item(.Cells(r, 1)) HO.Office = .Cells(r, 1) HO.INAKI = HO.INAKI + .Cells(r, 2) HO.INCA = HO.INCA + .Cells(r, 3) ' more properties HO.IncidentOnly = HO.IncidentOnly + .Cells(r, 10) 'We have to remove the existing object and add it again 'to reflect the updated totals col.Remove (.Cells(r, 1)) Else 'The location hasn't been added yet so create and add it HO.Office = .Cells(r, 1) HO.INAKI = .Cells(r, 2) HO.INCA = .Cells(r, 3) ' More properties HO.IncidentOnly = .Cells(r, 10) End If col.Add HO, .Cells(r, 1) 'Important to clear our object or our totals are wrong! :) Set HO = Nothing Next r End With 'Now we simply loop through our collection of offices and 'print out the totals. r = 6 'The first office starts on row 6 in your picture With Sheet2 For Each HO In col .Cells(r, "A").Value = HO.Office .Cells(r + 1, "C").Value = "IN - AK, HI" .Cells(r + 1, "F").Value = HO.INAKI .Cells(r + 2, "C").Value = "IN - CA" .Cells(r + 2, "F").Value = HO.INCA 'Continuing on for all 10 types .Cells(r + 10, "C").Value = "Incident Only" .Cells(r + 10, "F").Value = HO.IncidentOnly Set HO = Nothing r = r + 13 'So the next office starts 13 rows later...Row 19 in your pic Next End With End Sub Function InCol(col As Collection, key As Variant) As Boolean 'Returns TRUE if the object is in the collection or FALSE if it is not Dim obj As New HomeOffice On Error GoTo err InCol = True 'If the key doesn't exist, it throws an error and set the function to false Set obj = col(key) Set obj = Nothing Exit Function err: InCol = False End Function 

这是一个截然不同的方法，涉及一些更强硬的概念。 就像我说的，根据原始数据格式的不同，它可能不起作用，但也许它可以给你一个不同的方式来处理你的问题。