在Excel VBAsearch中search一个值

我对这个VBA世界完全陌生，我只是抓表面，需要任何帮助。

这里是我的问题我试图写一个代码，find一个值（第一个值），如果find值，开始一个新的search，find一个子值，而没有达到第二个命中（第一个值）的地址[完全很难这里解释是这个例子]

如果我有一个名字如下面的名单

John C age 32 address bla bla bla DOB 1/2/1990 Marc D DOB 1/2/1989 age 32 address bla bla bla 2 John D address bla bla bla3 age 48 DOB 1/2/1970 David K age 32 address bla bla bla 4 DOB 1/2/1985 

我需要做到以下几点

1. 首先寻找所有名叫约翰的人
2. 在不同的工作表中键入名称
3. 然后得到每个约翰find的年龄
4. 在名称旁边的单元格中键入该年龄

我尝试了一个代码，但我认为它有点不准确

 Sub Copy_To_Another_Sheet_1() Dim FirstAddress As String Dim MyArr As Variant Dim MyArr2 As Variant Dim Rng As Range Dim Rng2 As Range Dim Rcount As Long Dim I As Long Dim J As Long Dim NewSh As Worksheet With Application .ScreenUpdating = False .EnableEvents = False End With MyArr = Array("John") MyArr2 = Array("Age") Set NewSh = Sheets("Sheet3") With Sheets("Sheet1").Range("A1:Z1000") Rcount = 5 For I = LBound(MyArr) To UBound(MyArr) Set Rng = .Find(What:=MyArr(I), _ After:=.Cells(.Cells.Count), _ LookIn:=xlFormulas, _ LookAt:=xlPart, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False) If Not Rng Is Nothing Then FirstAddress = Rng.Address Do Rcount = Rcount + 1 Rng.Copy NewSh.Range("G" & Rcount) Set Rng = .FindNext(Rng) For J = LBound(MyArr2) To UBound(MyArr2) Set Rng2 = .Find(What:=MyArr2(J), _ After:=Rng, _ LookIn:=xlFormulas, _ LookAt:=xlPart, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False) If Not Rng2 Is Nothing Then Rng2.Offset(, 1).Copy NewSh.Range("H" & Rcount) End If Next J Set Rng = .FindNext(Rng) Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress End If Next I End With With Application .ScreenUpdating = True .EnableEvents = True End With End Sub 

我在这里使用数组设置我的search参数，因为在该代码的最终版本，我需要能够find名称及其相关信息的列表。

在find第一对值之后，我不断收到错误信息。

很感谢任何forms的帮助

提前致谢

Answer 1

你可能想要尝试重构你的代码

 Option Explicit Sub Copy_To_Another_Sheet_1() Dim namesArr As Variant, name As Variant Dim dataArr As Variant, datum As Variant Dim rCount As Long Dim reportSht As Worksheet Dim namesRng As Range Dim arr As Variant With Application .ScreenUpdating = False .EnableEvents = False End With namesArr = Array("John", "Mark") dataArr = Array("Age", "Address", "DOB") Set reportSht = Sheets("Sheet3") rCount = 5 '<--| initialize row index to start writing data from With Sheets("Sheet1") '<--| reference "Sheet1" With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)) '<--| reference its column "A" cells from row 1 down to last non empty one For Each name In namesArr '<--| loop through "names" array Set namesRng = GetNames(.Cells, name) '<--| collect current name occurrences in referenced cells If Not namesRng Is Nothing Then '<--| if any occurrence has been found then... For Each datum In dataArr '<--| ...loop through "data" array arr = GetData(name, namesRng, datum) '<--| collect current "data" occurrences under current name ones If IsArray(arr) Then '<-- if any data has been found then... reportSht.Range("G" & rCount).Resize(, UBound(arr) + 1).Value = arr '<-- ... write data in 'reportShtt' rCount = rCount + 1 '<--| update row index to write data in End If Next datum End If Next name End With End With With Application .ScreenUpdating = True .EnableEvents = True End With End Sub Function GetNames(rng As Range, name As Variant) As Range Dim f As Range, unionRng As Range Dim firstAddress As String Set unionRng = rng.Resize(1, 1).Offset(, 1) With rng Set f = .Find(What:=name, _ After:=.Cells(.Cells.Count), _ LookIn:=xlFormulas, _ LookAt:=xlPart, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False) If Not f Is Nothing Then firstAddress = f.Address Do Set unionRng = Union(unionRng, f) Set f = .FindNext(f) Loop While Not f Is Nothing And f.Address <> firstAddress End If Set GetNames = Intersect(unionRng, .Cells) End With End Function Function GetData(name As Variant, rng As Range, datum As Variant) As Variant Dim cell As Range Dim data As String For Each cell In rng Do While cell <> "" If UCase(cell) = UCase(datum) Then data = data & cell.Offset(, 1) & "|" Exit Do End If Set cell = cell.Offset(1) Loop Next cell If data <> "" Then GetData = Split(name & "|" & Left(data, Len(data) - 1), "|") End Function 

Answer 2

有很多方法可以完成你想要的。 我最喜欢的是创build一个用户定义的对象（类模块），然后只是拉出我想要的项目。 编程是复杂的，但有很大的灵活性。

这是使用Excel的AutoFilter的另一种方法。

• 使用InputBox来获取名称进行过滤。 这也可以用其他方法来设定。
• 首先，我们将数据重组为一个我们可以过滤的表格。
• 使用通配符筛选选定的名称，以便获得以该名称开头的任何内容
• 隐藏我们不感兴趣的列
• 将可见单元格复制到工作表的顶部，并清除表格

你也可以按名称对表格进行sorting – 一旦你有了表格，你可以做的各种事情。

 Option Explicit Sub FilterList() 'could set this in many different ways 'I suggest an input box if it will change frequently Dim sName As String Dim wsSrc As Worksheet, wsRes As Worksheet Dim rSrc As Range, rRes As Range Dim vSrc As Variant, vRes As Variant Dim I As Long, J As Long sName = InputBox("Enter Search Name") Set wsSrc = Worksheets("sheet1") Set wsRes = Worksheets("sheet3") Set rRes = wsRes.Cells(1, 1) With wsSrc Set rSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=2) End With 'read source data into array vSrc = rSrc 'dimension results array ReDim vRes(0 To WorksheetFunction.CountIf(rSrc, "DOB"), 1 To 4) 'Results array header vRes(0, 1) = "Name" vRes(0, 2) = "Age" vRes(0, 3) = "Address" vRes(0, 4) = "DOB" 'Populate the results array J = 0 For I = 1 To UBound(vSrc, 1) Select Case vSrc(I, 1) Case "age" vRes(J, 2) = vSrc(I, 2) Case "address" vRes(J, 3) = vSrc(I, 2) Case "DOB" vRes(J, 4) = vSrc(I, 2) Case "" 'do nothing Case Else 'then it is a name J = J + 1 vRes(J, 1) = vSrc(I, 1) End Select Next I 'Write the results to the worksheet Set rRes = rRes.Resize(rowsize:=UBound(vRes, 1) + 1, columnsize:=UBound(vRes, 2)).Offset(UBound(vRes, 1) + 1) With rRes .EntireColumn.Clear .Value = vRes 'Do some formatting With .Rows(1) .Font.Bold = True .HorizontalAlignment = xlCenter End With .Columns(4).NumberFormat = "m/d/yyyy" .EntireColumn.AutoFit End With 'Filter and hide unwanted data, 'then copy wanted data to top of sheet With wsRes If .AutoFilterMode Then .ShowAllData With rRes .AutoFilter Field:=1, Criteria1:="=" & sName & "*" .Range(.Columns(3), .Columns(4)).EntireColumn.Hidden = True .SpecialCells(xlCellTypeVisible).Copy .Worksheet.Cells(1, 1) .Worksheet.ShowAllData .Clear End With .Cells.EntireColumn.Hidden = False End With End Sub 

结果以John为名