从数据库中查找一个值，并将匹配值的列表另存为另一个表 [英] Lookup a value from database and get the list of matching values to another sheet

问题描述

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

  Col 1 col 2 col 3 
实验室名称光盘名称
（说abcd）xxxx 
 yyyy 
 zzzz 
 pppp 
  

，列表看起来像这样。

  Col 1 Col 2 
实验室名称光盘名称
 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来源比较

  FindString = fcomp 
 
 
带表格（list）。范围（q2：q106）'要搜索的单元格范围
 Set Rng = .Find（What：= FindString，_ 
 After：=。Cells（1），_ 
 LookIn： = xlValues，_ 
 LookAt：= xlWhole，_ 
 SearchOrder：= xlByRows，_ 
 SearchDirection：= xlPrevious，_ 
 MatchCase：= False）
 
如果Rng不是，然后
 
 
 
 Else 
尽管fcomp = FindString 
 fcomp.Offset（0，1）.Value = Rng.Offset （0，1）
 fcomp.Offset（1，1）.Value = Rng.Offset（0，1）
循环
 
结束如果
结束
  

下一个fcomp

结束子

这是我想要发生的真正的条件。

 转到列表，查看A2。 
如果列表A2与摘要A2匹配，则
转到摘要b2 
使摘要b2 value =列出b2值
然后chekc列表中的下一行
如果找到匹配总结a2然后
转到摘要，最后一个动作的单元格，向下移动一行，并将value =值与列中的列b中的值相匹配的单元格
重复此过程，直到找到摘要a2的所有匹配项。 
当summay a2的值改变时，启动此过程。 
  

解决方案

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

确保您的第二个选项卡被称为映射（或更改代码）。这个选项卡应该像你在问题中确定的那样有两列。

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

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

请注意，您可能需要即使您启用了自动计算，也可以点击CTRL + ALT + F9来强制重新计算所有内容。

 功能DisciplineLookup（TheLabName As String）As String 
 
 Dim objSheet As Worksheet，intUsedRows As Integer 
设置objSheet = Sheets（Mappings）
 intUsedRows = objSheet.UsedRange.Rows.Count 
 
'将所有相关数据导入到VBA数组中。 
 Dim objData（）As Variant 
 objData = objSheet.Range（A2，B& CStr（intUsedRows））值
 Dim objDisciplines As New Collection 
 
 
'查找匹配传递参数的行，并将其添加到集合
 Dim intI As Integer 
对于intI = 1对于intUsedRows  -  1 
如果objData（intI， 1）= TheLabName然后
 objDisciplines.Add objData（intI，2）
 End If 
 Next 
 
'将集合格式化为一个新的连接字符串
 '请注意，如果你有很多数据
'可能是非常慢的。如果是这样，请查看使用数组和JOIN函数
 Dim strDisciplines As String，strDiscipline As Variant 
 strDisciplines = 
对于每个strDiscipline在obj学科
 strDisciplines = strDisciplines& CStr（strDiscipline）& vbCrLf 
下一个
 
'修剪尾随CRLF 
如果Len（strDisciplines）> 0然后
 strDisciplines = Left（strDisciplines，Len（strDisciplines） -  2）
 End If 
 
 DisciplineLookup = strDisciplines 
 
结束函数
  

I want to find the corresponding Disc Codes from a list and copy them in the DiscName column in the summary sheet. some lab names will have more than one Disc codes so when I run the macro it should bring up all the relevant Disc Codes matching with the Lab name to DiscName column. Any help will be greatly appreciated. Not sure if I can upload the image of the summary sheet but i looks like this.

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

and the list looks something like this.

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   

I just re arranged the table so it looks more clearer. Hope this helps to understand my query better. Thanks again for any help.

I tried this code but I cannot get it to write the next Disc name in the next row after under Disc name in the summary sheet. It repeats the same Disc name as the first one. Ideally it should continue to fill in the Summary sheet with all the relevant Disc Names appearing agianst the Lab name in the list.

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

This is what I want to happen real symple terms.

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.

解决方案

This function will do something similar to what you're asking for. Place the code in a new module in the VBA editor.

Make sure your second tab is called "Mappings" (or change the code). This tab should have two columns just as you identified in your question.

Then just set cell B2 to the formula =DisciplineLookup(B1) and you should see the looked-up data. Note that you will also have to edit the formatting for column B to "Wrap Text" on the alignment tab.

I don't think this is exactly what you were looking for, but it may solve your problem. If this doesn't work, you might want to investigate creating a new tab with a macro that clears it and outputs a report when run.

Note that you may have to hit CTRL+ALT+F9 to forcefully recalculate everything if you update the base data even if you have auto-calculations enabled.

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

这篇关于从数据库中查找一个值，并将匹配值的列表另存为另一个表的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！