Question

我对这个VBA世界完全陌生，我只是摸不着头脑，需要任何帮助。

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

如果我有一个名称列表，如下面的

    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

我需要实现以下

首先搜索所有名为John的人
在不同的工作表中输入名称
然后获得每个John找到的年龄
在名称

我尝试了一段代码，但我觉得它有点不准确

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

我在这里使用Array来设置我的搜索参数，因为在该代码的最终版本中，我需要能够找到名称及其相关信息的列表。

找到前几个值后，我一直收到错误。

非常感谢任何帮助

提前致谢

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

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

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

使用InputBox获取要过滤的名称。这也可以通过许多其他方式设置。
首先，我们将数据重组为可以过滤的表格。
使用外卡过滤所选名称，以便我们以该名称开头
隐藏我们不感兴趣的列
将可见单元格复制到工作表的顶部，然后清除表格

您还可以按名称对表格进行排序 - 您可以在拥有表格后执行各种操作。

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 作为名称的结果

在Excel VBA中搜索搜索中的值

2 个答案: