我有一个很大的类似报告列表，这些报告在第一列中都有一个“Name：”单元格，并列出了一组对象，比如同一列中的“对象”。在字符串“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
答案 0 :(得分：1)
修订4/3：更改对象名称;改变案例;在4/2再次修订：搜索特定类型的对象;修订4/2;首先跳过'名字';如果达到最大值则结束循环（输入格式问题！） 修订4/1;添加错误陷阱＆amp;线＃找到错误。有助于看到用户输入。请参阅代码中的注释。
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