0

我有一个数据表。假设“A”列有很多品种的狗：Lab、Beagle、Golden 和 Poodle。

“B”列有他们的名字。有很多狗都是由这四个品种组成的，都有不同的名字。

“C”列有它们的位置：纽约、德克萨斯、路易斯安那和佛罗里达

我想做的是编写一个脚本，在“A”列中搜索所有住在纽约的实验室。一旦脚本找到这些狗，它就会获取它们的名字，并将它们的名字放在单独的工作表的列中。

我需要为所有的狗做到这一点。单独的工作表应该有纽约、德克萨斯、路易斯安那和佛罗里达的清单，下面有所有狗的名字。我计划根据品种对狗名进行颜色编码。

我在想我可以使用这种Find方法，但是老实说，我没有过多地使用 VBA，而且我的谷歌搜索也不太成功。谢谢你的帮助

4

1 回答 1

0

Try something like this. Tweak as needed.

Option Explicit

Sub TestDogs()
Dim dogBreed As String
Dim dogName As String
Dim dogLoc As String
Dim rngFound As Range
Dim wsMaster As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim arrDogs() As String
Dim i As Long

Set wsMaster = Worksheets("List") '<modify as needed.'
wsMaster.Activate
Range("A1").Activate
dogBreed = InputBox("Enter the breed", "Dog Breed", "Lab")
dogLoc = InputBox("Enter the location", "Dog location", "New York")

Set rng = Range("A1", Range("a1").End(xlDown))
Range("A1").Activate
Do
    'use the .Find method to look for dog breed in column A'

    Set rngFound = rng.Find(What:=dogBreed, After:=ActiveCell, LookIn:= _
        xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
        xlNext, MatchCase:=True, SearchFormat:=False)

    If Not rngFound Is Nothing Then
        rngFound.Activate
        'Check to see if the Location matches:'
        If rngFound.Offset(0, 2).Value = dogLoc Then
            dogName = rngFound.Offset(0, 1).Value
            'If so, then add to the array'
            ReDim Preserve arrDogs(i)
            arrDogs(i) = dogName
            i = i + 1
            If i >= Application.WorksheetFunction.CountIf(rng, dogBreed) - 1 Then Exit Do
        End If
    Else: Exit Do
    End If

'Loop, the counter variable "i" will exit this loop when necessary.
Loop

If UBound(arrDogs) >= 0 Then
    'Add a new sheet if any matches were found
    Set wsNew = Sheets.Add(After:=wsMaster)

    With wsNew
        'Give the sheet a meaningful name.'
        .Name = Left(dogBreed & " - " & dogLoc, 31)
        'Print out the dog names on the new sheet'
        .Range("A1", .Range("A1").Offset(UBound(arrDogs), 0)).Value = WorksheetFunction.Transpose(arrDogs)
    End With
Else:
    MsgBox "No dogs matching criteria [Breed =" & dogBreed & "] and [Location =" & dogLoc & "]", vbInformation

End If
End Sub
于 2013-04-02T22:00:53.097 回答