VBA从另一个工作表的多个条目中获取精确匹配,返回真/假。

huangapple go评论69阅读模式
英文:

VBA get exact match from multiple entries on another sheet return true/false

问题

我尝试使用索引/匹配、VLOOKUP、IF语句等方法来做这个,我已经搜索了好几天(可能是因为我不知道如何正确定义我正在做的事情)。VBA对我来说是新的。

我有2个工作表,第一个工作表(dataWs)是要搜索的数据,标题为Ach。列A包含约3500行员工ID。列B包含工作职责代码。一个员工可能有1到20个工作代码条目,根据他们有资格执行的工作而定。还有其他列用于状态和到期日期,但这些与问题无关。

工作表1

第2个工作表(outputWs)包含列A中的ID号码(以及列B中的联系电子邮件)。我希望列C能够在工作表1的列A中找到ID号码,然后在该ID的所有条目中,在工作表1的列B中查找工作代码53,然后在工作表2的列C中反映出员工ID是否有资格执行工作职责53,如果更简单的话,只需将"53"放在列C中也可以。

工作表2

以下是一个标准的索引匹配,用于ID查找,但不考虑代码53的查找:

Sub findJobQual ()

Dim outputWs As Worksheet, dataWs As Worksheet
Dim outputLastRow As Long, dataLastRow As Long, x As Long
Dim IndexRng As Range, MatchRng As Range

'Sources
Set outputWs = ThisWorkbook.Worksheets("Qualified")
Set dataWs = ThisWorkbook.Worksheets("Ach")

'count rows in tables
outputLastRow = outputWs.Range("A" & Rows.Count).End(xlUp).Row
dataLastRow = dataWs.Range("A" & Rows.Count).End(xlUp).Row

'Data column to return values from (Desired return)
Set IndexRng = dataWs.Range("B2:B" & dataLastRow)

'Data sent match to(Row)(Column)
Set MatchRng = IndexRng.Offset(0, -1)

On Error Resume Next

    For x = 2 To outputLastRow
                     'Send Cell
        outputWs.Range("A" & x).Value = Application.WorksheetFunction.Index(IndexRng, _
        Application.WorksheetFunction.Match(outputWs.Range("C" & x).Value, MatchRng, 0))
                                                          'Return Cell
    Next x

End Sub

我知道上面的代码可能是不完整的,或者可能不是我尝试做的方法。我提供它作为一个模板,因为它将匹配ID号码并在工作簿的其他部分输出一个值。上面的代码可能仍然需要调整以适应我提供的信息。我知道我需要添加另一个参数,但我不确定如何添加。

英文:

I have attempted to do this with index/match, vlookup, If statements, etc. I have searched for days (It it possible I don't know how to define what I am doing properly). VBA is new to me.

I have 2 sheets, the first Sheet (dataWs) is data to search titled Ach. Column A contains employee ID's on or about 3500 rows. Column B contains job duty codes. A single employee may have 1 or 20 job code entries, based on jobs they are qualified to perform. There are other columns for status and expire date, but they are not relevant.

Sheet 1

Sheet 2 (outputWs) contains ID numbers in column A (and a contact email in column B). I would like column C to find ID number in Sheet 1 column a, then in all entries for that ID, find job code 53 in sheet1 column B then reflect true or false if the employee ID is qualified to perform job duty 53 on Sheet 2 column C. If it is easier - putting just "53" in column c would also work.

Sheet 2

Here is a standard index match that works for ID lookup but does not consider the code 53 lookup:

Sub findJobQual ()

Dim outputWs As Worksheet, dataWs As Worksheet
Dim outputLastRow As Long, dataLastRow As Long, x As Long
Dim IndexRng As Range, MatchRng As Range

'Sources
Set outputWs = ThisWorkbook.Worksheets("Qualified")
Set dataWs = ThisWorkbook.Worksheets("Ach")

'count rows in tables
outputLastRow = outputWs.Range("A" & Rows.Count).End(xlUp).Row
dataLastRow = dataWs.Range("A" & Rows.Count).End(xlUp).Row

'Data column to return values from (Desired return)
Set IndexRng = dataWs.Range("B2:B" & dataLastRow)

'Data sent match to(Row)(Column)
Set MatchRng = IndexRng.Offset(0, -1)

On Error Resume Next

    For x = 2 To outputLastRow
                     'Send Cell
        outputWs.Range("A" & x).Value = Application.WorksheetFunction.Index(IndexRng, _
        Application.WorksheetFunction.Match(outputWs.Range("C" & x).Value, MatchRng, 0))
                                                          'Return Cell
    Next x

End Sub

I am aware that the above code is incomplete or may not be the method to do what I am trying to do. I am providing it as a boiler plate, as it will match ID numbers and output a value in other parts of my workbook. the above code may still need adjustment to work with the info I have provided. I know I need to add another argument but I am not sure how.

答案1

得分: 1

以下是您要求的代码的中文翻译部分:

子 FlagJobQualifications()

    常数 SRC_SHEET 作为 字符串 = "Qualified"
    常数 SRC_ID_COLUMN 作为 长整型 = 1
    常数 SRC_ACH_COLUMN 作为 长整型 = 2

    常数 DST_SHEET 作为 字符串 = "Ach"
    常数 DST_ID_COLUMN 作为 长整型 = 1
    常数 DST_ACH_COLUMN 作为 长整型 = 3
    常数 DST_ACH_LOOKUP_CELL 作为 字符串 = "C1"
    常数 DST_ACH_PREFIX 作为 字符串 = "Code "
    常数 DST_FLAG_YES = True
    常数 DST_FLAG_NO = False

    Dim wb 作为 工作簿: 设置 wb = ThisWorkbook

    Dim sws 作为 工作表: 设置 sws = wb.Sheets(SRC_SHEET)

    Dim rg 作为 范围, rCount 作为 长整型

    使用 sws.Range("A1").CurrentRegion
        rCount = .Rows.Count - 1
        如果 rCount = 0 Then
            MsgBox "工作表 """ & SRC_SHEET & """ 中没有数据。", vbCritical
            退出子程序
        End If
        设置 rg = .Resize(rCount).Offset(1)
    结束使用

    Dim dict 作为 对象: 设置 dict = CreateObject("Scripting.Dictionary")
    'dict.CompareMode = vbTextCompare ' 由于只涉及数字,因此不必要

    Dim rrg 作为 范围, iStr 作为 字符串, aStr 作为 字符串

    对于 每个 rrg 在 rg.Rows 中
        iStr = CStr(rrg.Cells(SRC_ID_COLUMN).Value)
        如果 Len(iStr) > 0 Then
            如果 不 dict.Exists(iStr) 则
                设置 dict(iStr) = CreateObject("Scripting.Dictionary")
                'dict(iStr).CompareMode = vbTextCompare ' 不必要...
            结束如果
            aStr = CStr(rrg.Cells(SRC_ACH_COLUMN).Value)
            如果 不 dict(iStr).Exists(aStr) 则
                dict(iStr)(aStr) = Empty
            结束如果
        结束如果
    下一个 rrg

    如果 dict.Count = 0 Then
        MsgBox "工作表 """ & SRC_SHEET & """ 中只有空白。", vbCritical
        退出子程序
    End If

    Dim dws 作为 工作表: 设置 dws = wb.Sheets(DST_SHEET)

    使用 dws.Range("A1").CurrentRegion
        rCount = .Rows.Count - 1
        如果 rCount = 0 Then
            MsgBox "工作表 """ & DST_SHEET & """ 中没有数据。", vbCritical
            退出子程序
        End If
        设置 rg = .Resize(rCount).Offset(1)
    结束使用

    Dim daCell 作为 范围: 设置 daCell = dws.Range(DST_ACH_LOOKUP_CELL)
    Dim daStr 作为 字符串: daStr = CStr(daCell.Value)

    如果 InStr(1, daStr, DST_ACH_PREFIX, vbTextCompare) <> 1 Then
        MsgBox "字符串 'Ach' """ & daStr & """ 无效。", vbExclamation
        退出子程序
    结束如果

    aStr = Right(daStr, Len(daStr) - Len(DST_ACH_PREFIX))

    Dim IsQualified 作为 布尔值

    对于 每个 rrg 在 rg.Rows 中
        iStr = CStr(rrg.Cells(DST_ID_COLUMN).Value)
        如果 dict.Exists(iStr) 则
            如果 dict(iStr).Exists(aStr) 则
                IsQualified = True
            结束如果
        结束如果
        如果 IsQualified 则
            rrg.Cells(DST_ACH_COLUMN).Value = DST_FLAG_YES
            IsQualified = False ' 为下一次迭代重置
        否则
            rrg.Cells(DST_ACH_COLUMN).Value = DST_FLAG_NO
        结束如果
    下一个 rrg

    MsgBox "已标记职位资格。", vbInformation

结束子程序

希望这对您有所帮助。如果您有其他问题,请随时提出。

英文:

A VBA Lookup (Dictionary of Dictionaries)

  • The keys of the dictionary hold the unique Ids while the items hold dictionaries whose keys hold the Achs.

VBA从另一个工作表的多个条目中获取精确匹配,返回真/假。

<!-- language: lang-vb -->

Sub FlagJobQualifications()

    Const SRC_SHEET As String = &quot;Qualified&quot;
    Const SRC_ID_COLUMN As Long = 1
    Const SRC_ACH_COLUMN As Long = 2
    
    Const DST_SHEET As String = &quot;Ach&quot;
    Const DST_ID_COLUMN As Long = 1
    Const DST_ACH_COLUMN As Long = 3
    Const DST_ACH_LOOKUP_CELL As String = &quot;C1&quot;
    Const DST_ACH_PREFIX As String = &quot;Code &quot;
    Const DST_FLAG_YES = True
    Const DST_FLAG_NO = False
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET)
    
    Dim rg As Range, rCount As Long
    
    With sws.Range(&quot;A1&quot;).CurrentRegion
        rCount = .Rows.Count - 1
        If rCount = 0 Then
            MsgBox &quot;No data in worksheet &quot;&quot;&quot; &amp; SRC_SHEET &amp; &quot;&quot;&quot;.&quot;, vbCritical
            Exit Sub
        End If
        Set rg = .Resize(rCount).Offset(1)
    End With
    
    Dim dict As Object: Set dict = CreateObject(&quot;Scripting.Dictionary&quot;)
    &#39;dict.CompareMode = vbTextCompare &#39; not necessary since only digits
    
    Dim rrg As Range, iStr As String, aStr As String
    
    For Each rrg In rg.Rows
        iStr = CStr(rrg.Cells(SRC_ID_COLUMN).Value)
        If Len(iStr) &gt; 0 Then
            If Not dict.Exists(iStr) Then
                Set dict(iStr) = CreateObject(&quot;Scripting.Dictionary&quot;)
                &#39;dict(iStr).CompareMode = vbTextCompare &#39; not necessary...
            End If
            aStr = CStr(rrg.Cells(SRC_ACH_COLUMN).Value)
            If Not dict(iStr).Exists(aStr) Then
                dict(iStr)(aStr) = Empty
            End If
        End If
    Next rrg
    
    If dict.Count = 0 Then
        MsgBox &quot;Only blanks in worksheet &quot;&quot;&quot; &amp; SRC_SHEET &amp; &quot;&quot;&quot;.&quot;, vbCritical
        Exit Sub
    End If
    
    Dim dws As Worksheet: Set dws = wb.Sheets(DST_SHEET)
    
    With dws.Range(&quot;A1&quot;).CurrentRegion
        rCount = .Rows.Count - 1
        If rCount = 0 Then
            MsgBox &quot;No data in worksheet &quot;&quot;&quot; &amp; DST_SHEET &amp; &quot;&quot;&quot;.&quot;, vbCritical
            Exit Sub
        End If
        Set rg = .Resize(rCount).Offset(1)
    End With
        
    Dim daCell As Range: Set daCell = dws.Range(DST_ACH_LOOKUP_CELL)
    Dim daStr As String: daStr = CStr(daCell.Value)
        
    If InStr(1, daStr, DST_ACH_PREFIX, vbTextCompare) &lt;&gt; 1 Then
        MsgBox &quot;The &#39;Ach&#39; string &quot;&quot;&quot; &amp; daStr &amp; &quot;&quot;&quot; is invalid.&quot;, vbExclamation
        Exit Sub
    End If
        
    aStr = Right(daStr, Len(daStr) - Len(DST_ACH_PREFIX))
        
    Dim IsQualified As Boolean
        
    For Each rrg In rg.Rows
        iStr = CStr(rrg.Cells(DST_ID_COLUMN).Value)
        If dict.Exists(iStr) Then
            If dict(iStr).Exists(aStr) Then
                IsQualified = True
            End If
        End If
        If IsQualified Then
            rrg.Cells(DST_ACH_COLUMN).Value = DST_FLAG_YES
            IsQualified = False &#39; reset for the next iteration
        Else
            rrg.Cells(DST_ACH_COLUMN).Value = DST_FLAG_NO
        End If
    Next rrg
        
    MsgBox &quot;Job qualifications flagged.&quot;, vbInformation

End Sub

答案2

得分: 0

=NOT(ISERROR(MATCH(A2&"|53",Ach!$A$2:$A$2500&"|"&Ach!$B$2:$B$2500,0)))

英文:

Maybe you can try a formula like below (to be entered in column c in the second sheet

=NOT(ISERROR(MATCH(A2&"|53",Ach!$A$2:$A$2500&"|"&Ach!$B$2:$B$2500,0)))

答案3

得分: 0

probably we have different layout in sheets, and my formula didn't work.
Also your code works only if I exchange "C" <-> "A" in the For loop, but it is not important.

如果您的代码能够匹配单元格,那么可能最简单的测试方法就是在末尾添加 "=53" 进行测试。
当然,您也可以使用变量并从另一个单元格中读取它等。

outputWs.Range("A" & x).Value = Application.WorksheetFunction.Index(IndexRng, _
Application.WorksheetFunction.Match(outputWs.Range("C" & x).Value, MatchRng, 0)) = 53

英文:

probably we have different layout in sheets, and my formula didn't work.
Also your code works only if I exchange "C"<->"A" in the For loop, but it is not important.

If your code works for matching the cells so probably the simpliest measure to check it against 53 id just to add "=53" at the end to make a test.
Of course you can use a variable and read it from another cell etc.

outputWs.Range(&quot;A&quot; &amp; x).Value = Application.WorksheetFunction.Index(IndexRng, _
        Application.WorksheetFunction.Match(outputWs.Range(&quot;C&quot; &amp; x).Value, MatchRng, 0)) = 53

huangapple
  • 本文由 发表于 2023年7月18日 02:40:13
  • 转载请务必保留本文链接:https://go.coder-hub.com/76707271.html
匿名

发表评论

匿名网友

:?: :razz: :sad: :evil: :!: :smile: :oops: :grin: :eek: :shock: :???: :cool: :lol: :mad: :twisted: :roll: :wink: :idea: :arrow: :neutral: :cry: :mrgreen:

确定