计算给定标题下的非空白单元格

Question

我有很多类似的报告，这些报告在第一列中都有一个“名称：”单元格，并且在同一列中列出了一组对象，例如“对象”。在字符串“Name:”的两个实例和中间的一些其他行（空白和填充）之后，我们到达“Objects”字符串。在“对象”一词的每个实例之后，都有一个数字列表，用于计算对象的总数。每个列表中有任意数量的对象，但它们总是位于标题“对象”之后的事实是不变的。是否有一种简单的方法可以让 Excel 搜索每个报告并将在某个单元格中的“名称：”下找到的名称以及在其旁边的“对象”一词之后的所有非空白单元格的计数？由于对象列表是完整的，第一个空白单元格可能会触发计数停止并移至下一个列表，而大量空白单元格（例如超过 300 个）可能会触发程序声明不再有条目拉出并停止）。

示例

    A              B           C

    Name:      John Smith


    Date:       March 5th

    Name:       John Smith

   Objects
    List 
      1            Filler1     Something1
      2            Filler2     Something2
      3            Filler3     Something3
      4            Filler4     Something4
      5            Filler5     Something5
      6            Filler6     Something6

    Name:      Jane Doe


    Date:       March 8th

    Name:       Jane Doe

   Objects
    List 
      1            Filler1     Something1
      2            Filler2     Something2
      3            Filler3     Something3
      4            Filler4     Something4

结果会是这样的：

    John Smith         6
    Jane Doe           4

Answer 1

修订 4/3：更改对象名称；更改案例； 4月2日再次修订：搜索特定类型的对象；修订 4/2；跳过第一个“名称”；如果达到最大值，则结束循环（输入格式问题！） 4/1 修订；添加了错误陷阱和行号以查找错误。将有助于查看用户输入。请参阅代码中的注释。

    Option Explicit
' Assumptions:
' (1) All data in first column - except for name.
' (2) The literal 'Name:' will be in Col A; The name (i.e. 'John Doe') will be in Col B.
' (3) The same 'Name' will appear twice, with a 'Date' row between the two.
' (4) May be blank row(s) anywhere before or after row containing 'Name'.
' (5) 'Object' row will have string starting with 'Objects' in Col A, followed by Object Name (i.e. 'Objects Cars')
' (6) 'Object' row may repeat for ONE name.
' (7) Search for user specified Object in list for a Name. Set to zero if not found
' (8) Name will be repeated many times in the column (>100,000 rows).

' For test purposes, I have used 'Sheet1' as report sheet, and 'Sheet2' as output.
' Can change to process ALL sheets in a workbook (not sure how your reports are found (.. sheets or workbooks..)

Sub Create_Summary()
Dim lLastRow    As Long
Dim lRow        As Long
Dim lOutRow     As Long
Dim lNameRow    As Long

Dim sName       As String
Dim iNameCtr    As Integer
Dim lRowCt      As Long
Dim blnSkip     As Boolean
Dim strObjName  As String
Dim strObjKey  As String
Dim strObjNameFound As String

1000  On Error GoTo Error_Trap

'Get last used row
1010  lLastRow = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
1020  Debug.Print "Total Rows: " & lLastRow

1030  strObjKey = "Objects"     ' <<<<<<< Add code to obtain and set to whatever you want.
1040  strObjName = "Cars"     ' <<<<<<< Add code to obtain and set to whatever you want.

1050  lOutRow = 1
1060  blnSkip = False
1070  For lRow = 1 To lLastRow
1080      iNameCtr = 0
1090      lRowCt = 0
1100     Do Until iNameCtr = 2 Or lRow >= lLastRow    'Trim(Cells(lRow, 1)) = "Name:" Or lRow >= lLastRow      ' Find 'Name'
1110          If Trim(Cells(lRow, 1)) = "Name:" Then
1120              iNameCtr = iNameCtr + 1
1130              lNameRow = lRow
1140          End If
1150          lRow = lRow + 1
1160       Loop
1170      lRow = lRow - 1
1180      If lRow >= lLastRow - 1 Then Exit For
1190      If blnSkip = True Then
1200         sName = Cells(lRow, 2)            ' Name is in Col 2
1210         Debug.Print "Row: " & lRow & vbTab & ">> Name: " & sName
1220         Sheets("Sheet2").Range("A" & lOutRow) = sName      ' Save Name
            ' There will always be a non-blank row after 'Name' do not count that!
1230         lRow = lRow + 1
1240         Do Until LCase(Left(Cells(lRow, 1), 7)) = LCase(strObjKey) And InStr(8, LCase(Cells(lRow, 1)), LCase(strObjName)) > 0    ' Find 'Object'
1250             lRow = lRow + 1
1260             If LCase(Trim(Cells(lRow, 1))) = LCase("Name:") Then     ' Means never found desired 'Objects'
1270                 Sheets("Sheet2").Range("B" & lOutRow) = 0
1280                 lRow = lRow - 1
1290                 lOutRow = lOutRow + 1
1295                 GoTo Next_Row
1300             ElseIf lRow > lLastRow Then
1310                 Sheets("Sheet2").Range("B" & lOutRow) = lRowCt
1320                 Debug.Print "**** Exit because at end of used range!"
'134                 MsgBox "Found name: '" & sName & "' at row " & lNameRow & ", but there was no matching 'Objects'", vbOKOnly, "Sheet Format Incorrect"
1330                 Exit For
1340             End If
1350         Loop
1360         Debug.Print "Row: " & lRow & vbTab & ">> " & strObjKey & ": " & Cells(lRow, 1)
1370         strObjNameFound = Trim(Mid(Cells(lRow, 1), 8, 99))
1380         lRow = lRow + 2   ' Must skip a 'filler' line after 'Objects'

1390         Do Until Cells(lRow, 1) = "" Or LCase(Left(Cells(lRow, 1), 7)) = LCase(strObjKey) Or lRow >= lLastRow      ' Find Blank line
1400             If Cells(lRow, 1) <> "" Then
1410                 lRowCt = lRowCt + 1   ' Count Rows associated with Object
1420             End If
1430             lRow = lRow + 1
1440         Loop
1450         Debug.Print "Row: " & lRow & vbTab & "# " & strObjKey & ": " & lRowCt
1460         Sheets("Sheet2").Range("B" & lOutRow) = lRowCt
1470         Sheets("Sheet2").Range("C" & lOutRow) = strObjNameFound
1480         lOutRow = lOutRow + 1
1490     Else
1500         blnSkip = True
1510         lRow = lRow + 1
1520     End If
Next_Row:
1530  Next lRow

1540  Exit Sub

Error_Trap:
    Debug.Print Err.Number & vbTab & Err.Description & vbCrLf & _
            "At Line: " & Erl & vbCrLf & _
            "lLastRow = " & lLastRow & vbTab & "lRow = " & lRow
    MsgBox "Error: " & Err.Number & vbTab & Err.Description & vbCrLf & "At Line: " & Erl & vbCrLf & _
            "lLastRow = " & lLastRow & vbTab & "lRow = " & lRow
    Exit Sub
End Sub