Question

我有医疗术语列表（F列）及其相关的数字代码（G栏），我需要从B列的列表中的F列中找到医学术语，并将该术语的相关代码放在C列中。

电子表格简化版的图片：

运行代码后我想要的电子表格是什么样的：

我的问题是获取代码以查找列表中的下一个匹配项。我在图像中的示例是医学术语：abnormal gait。您可以看到B列中有两个匹配项（第一个和最后一个单元格）。我对此的代码是根据Microsoft和[许多论坛推荐作为资源的其他网站] [3]中的示例进行修改的。但是，无论我尝试修改第二个'find'命令多少次，我总是会遇到以下错误之一：

无法获取Range Class的FindNext属性
类型不匹配错误
Find函数重复查找相同的单元格

Find函数找到第一个单元格，但它永远不会找到下一个单元格并通过End If退出。

Sub Match2Cohort()
Dim Phenotype, FindMe, FoundinList As Range
Dim LRp, LastRow, i As Long
Dim FirstMatch As String

LRp = Cells(Rows.Count, 2).End(xlUp).Row
LastRow = Cells(Rows.Count, 6).End(xlUp).Row
Set Phenotype = Range("B1:b" & LRp)
Set Terms = Range("F1:f" & LastRow)

For i = 18 To LastRow
    FindMe = Cells(i, 6).Value
    Set FoundinList = Phenotype.Cells.Find(What:=FindMe, LookAt:=xlWhole)
    On Error Resume Next

    If Not FoundinList Is Nothing Then
        FirstMatch = FoundinList.Row
        Do
'This loop allows me to combine multiple medical codes into the same cell.                    
            If IsEmpty(FoundinList.Offset(0, 1)) = True Then
                    FoundinList.Offset(0, 1) = Cells(i, 7).Value
            Else: FoundinList.Offset(0, 1) = FoundinList.Offset(0, 1).Value & "/" & Cells(i, 7).Value
            FoundinList.Offset(0, 1).Select
            End If

'This is the code that is not working and all of the variations I've tried:
    With Phenotype
        Set FoundinList = .FindNext(FindMe)
        Set FoundinList = .FindNext(FindMe, After:=ActiveCell)
        Set FoundinList = .FindNext(After:=ActiveCell)
    End With

        Set FoundinList = Phenotype.FindNext(What:=FindMe, After:=ActiveCell, LookAt:=xlWhole)
        Set FoundinList = Phenotype.Find(What:=FindMe, After:=ActiveCell, LookAt:=xlWhole)
        Set FoundinList = Phenotype.FindNext(After:=FoundinList)
        Set FoundinList = Phenotype.FindNext(What:=FindMe, After:=FoundinList, LookAt:=xlWhole)
        Set FoundinList = Phenotype.Find(What:=FindMe, After:=FoundinList, LookAt:=xlWhole)

        Loop While FirstMatch <> FoundinList.Row
    End If
Next i

End Sub

此时我已经尝试了我能想到的一切以及我在网上找到的所有内容，并且不知道下一步该尝试什么。

Answer 1

我认为这就是你要写的内容：

Sub Match2Cohort()

    Dim Phenotype As Range, FindMe As String, FoundinList As Range
    Dim LRp As Long, LastRow As Long, i As Long
    Dim FirstMatch As String
    Dim Terms As Range

    LRp = Cells(Rows.Count, 2).End(xlUp).Row
    LastRow = Cells(Rows.Count, 6).End(xlUp).Row
    Set Phenotype = Range("B1:B" & LRp)
    Set Terms = Range("F1:F" & LastRow)

    For i = 18 To LastRow
        FindMe = Cells(i, 6).Value2

        'Find first occurrence.
        Set FoundinList = Phenotype.Cells.Find( _
            What:=FindMe, _
            After:=Phenotype.Cells(1), _
            LookAt:=xlPart, _
            SearchDirection:=xlNext)

        If Not FoundinList Is Nothing Then
            FirstMatch = FoundinList.Address
            Do
                If IsEmpty(FoundinList.Offset(0, 1)) Then 'No need for "=TRUE" as the statement returns TRUE/FALSE
                    FoundinList.Offset(0, 1) = Cells(i, 7).Value
                Else
                    FoundinList.Offset(0, 1) = FoundinList.Offset(0, 1).Value & "/" & Cells(i, 7).Value
                End If

                Set FoundinList = Phenotype.FindNext(FoundinList)
            Loop While Not FoundinList Is Nothing And FirstMatch <> FoundinList.Address
        End If

    Next i

End Sub

Answer 2

以下是您的问题的有效解决方案，不使用.Find或.FindNext方法。

Sub Match2Cohort()
    Dim i&, k&, TTmp$, PTmp$, p, t
    t = [f1].CurrentRegion.Resize(, 2)
    With ActiveSheet
        p = [b1].Resize(.Cells(.Rows.Count, "b").End(xlUp).Row, 2)
    End With
    For i = 1 To UBound(t)
        TTmp = LCase$(Replace(t(i, 1), " ", ""))
        For k = 1 To UBound(p)
            PTmp = "," & LCase$(Replace(p(k, 1), " ", "")) & ","
            If InStr(PTmp, "," & TTmp & ",") Then
                PTmp = p(k, 2) & "/" & t(i, 2)
                If Left$(PTmp, 1) = "/" Then PTmp = Mid$(PTmp, 2)
                p(k, 2) = PTmp
            End If
        Next
    Next
    [b1].Resize(UBound(p), UBound(p, 2)) = p
End Sub

Answer 3

好的，所以我认为最好的解决方案是远离FIND（）并使用strings.split，application.index和application.match

这是逻辑：

循环1'循环遍历B列中的单元格

将单元格文本拆分为逗号并放入数组

循环2'循环通过单个表型阵列

使用application.match在F：G

列中查找术语和代码

将代码添加到C列的单元格中。

以下是代码：

Sub Text_Loop()
Dim i As Integer
Dim RngF as Range, RngB As Range
Dim mycell As Range
Dim phenoString() As String
Dim phenoCode As Variant

Set RngB = Sheet1.Range("b2:b" & Sheet1.Range("b2").End(xlDown).Row)
Set RngF = Sheet1.Range("F2:F" & Sheet1.Range("F2").End(xlDown).Row)

For Each mycell In RngB 'first loop
    phenoString = Split(mycell.Value, ",")

    For i = LBound(phenoString) To UBound(phenoString) 'second loop
        phenoCode = Application.Index(Sheet1.Range("F2:G" & Sheet1.Range("F2").End(xlDown).Row), _
            Application.Match(phenoString(i), RngF, 0), 2) 'use variant so that we can check for an error

        If WorksheetFunction.IsError(phenoCode) = False Then 'checks to make sure phenocode was found
            If mycell.Offset(0, 1) <> "" Then 'formats multiple phenotype codes with / in correct place
                mycell.Offset(0, 1) = mycell.Offset(0, 1) & "/" & phenoCode
            Else
                mycell.Offset(0, 1) = phenoCode
            End If
        End If

    Next i 'end first loop
Next mycell 'end second loop


End Sub

'.Find'/'。FindNext'重复找到相同的单元格或返回错误

3 个答案: