Question

我想从列表中找到相应的光盘代码，并将它们复制到摘要表的DiscName列中。一些实验室名称将包含多个光盘代码，因此当我运行宏时，它应该将与Lab名称匹配的所有相关光盘代码显示到DiscName列。任何帮助将不胜感激。不确定我是否可以上传摘要表的图像，但我看起来像这样。

Col 1                col 2     col 3
Lab name             Disc Name
(say abcd)           xxxx
                     yyyy
                     zzzz
                     pppp

，列表看起来像这样。

Col 1          Col 2
Lab name       Disc name
abcd            xxxxx
abcd            yyyyy
abcd            zzzzz
abcd            ppppp
bcda            qqqqq
bcda            rrrrr
bcda            iiiii
bcda            jjjjj
bcda            kkkkk

我刚安排好桌子，看起来更清晰。希望这有助于更好地理解我的查询。再次感谢任何帮助。

我尝试了这段代码但是我无法在摘要表中的光盘名称下面的下一行写下一个光盘名称。它重复与第一个相同的光盘名称。理想情况下，它应该继续填写摘要表，其中所有相关的光盘名称都显示在列表中的实验室名称中。

Sub Vlooker（）

Dim FindString As String 昏暗的范围昏暗的fcomp 对于每个fcomp In Sheets（“cont”）。Range（“p3”）'范围的源比较

FindString = fcomp


    With Sheets("list").Range("q2:q106") 'range of cells to search
        Set Rng = .Find(What:=FindString, _
                        After:=.Cells(1), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False)

        If Rng Is Nothing Then



        Else
        Do While fcomp = FindString
          fcomp.Offset(0, 1).Value = Rng.Offset(0, 1)
          fcomp.Offset(1, 1).Value = Rng.Offset(0, 1) 
          Loop

        End If
    End With

下一个fcomp

End Sub

这就是我想要发生的实际问题。

Go to List, Check A2. 
If list A2 matches with Summary A2 then 
go to summary b2
make summary b2 value = to list b2 value
then chekc next row in list
if found match with summary a2 then
go to summary, last actioned cell, go one row down and make value = to the value in column b in  list against the matching cell
Repeat this process till all matches found for summary a2.
Start this process when ever value of summay a2 changes.

Answer 1

此功能将执行类似于您要求的操作。将代码放在VBA编辑器中的新模块中。

确保您的第二个标签名为“Mappings”（或更改代码）。此标签应该有两列，就像您在问题中确定的一样。

然后将单元格B2设置为公式= DisciplineLookup（B1），您应该看到查找的数据。请注意，您还必须在对齐选项卡上将B列的格式编辑为“Wrap Text”。

我认为这不是你想要的，但它可以解决你的问题。如果这不起作用，您可能需要调查创建一个带有宏的新选项卡，该宏清除它并在运行时输出报告。

请注意，即使您启用了自动计算，如果更新基础数据，也可能必须按CTRL + ALT + F9强制重新计算所有内容。

Function DisciplineLookup(TheLabName As String) As String

    Dim objSheet As Worksheet, intUsedRows As Integer
    Set objSheet = Sheets("Mappings")
    intUsedRows = objSheet.UsedRange.Rows.Count

    'Get all of the relevant data into a VBA array.
    Dim objData() As Variant
    objData = objSheet.Range("A2", "B" & CStr(intUsedRows)).Value
    Dim objDisciplines As New Collection


    'Find rows matching the passed parameter, and add them to a collection
    Dim intI As Integer
    For intI = 1 To intUsedRows - 1
        If objData(intI, 1) = TheLabName Then
            objDisciplines.Add objData(intI, 2)
        End If
    Next

    'Format the collection into a new concatenated string
    'Note this may be really slow if you have a lot of data
    ' If so, look into using an array and the JOIN function
    Dim strDisciplines As String, strDiscipline As Variant
    strDisciplines = ""
    For Each strDiscipline In objDisciplines
        strDisciplines = strDisciplines & CStr(strDiscipline) & vbCrLf
    Next

    'trim trailing CRLF
    If Len(strDisciplines) > 0 Then
        strDisciplines = Left(strDisciplines, Len(strDisciplines) - 2)
    End If

    DisciplineLookup = strDisciplines

End Function

从数据库中查找值并获取匹配值列表到另一个工作表

1 个答案: