1

我想从列表中找到相应的光盘代码并将它们复制到摘要表的 DiscName 列中。一些实验室名称将有多个光盘代码，因此当我运行宏时，它应该将与实验室名称匹配的所有相关光盘代码显示到 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
    Dim Rng As Range
    Dim fcomp
    For Each fcomp In Sheets("cont").Range("p3") ' range of Source Comparison

        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
             
  Next 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.
4

1 回答 1

0

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

确保您的第二个选项卡名为“映射”（或更改代码）。正如您在问题中确定的那样，此选项卡应该有两列。

然后只需将单元格 B2 设置为公式 =DisciplineLookup(B1)，您应该会看到查找的数据。请注意，您还必须将 B 列的格式编辑为对齐选项卡上的“换行文本”。

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

请注意，即使您启用了自动计算，如果您更新基础数据，您可能必须按 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
于 2013-09-21T23:44:15.773 回答