查找在两列中具有匹配值的每一行

Question

我有一个电子表格，用于管理我们即将更新的政策。有些客户有多个同时到期的政策，每个政策都显示在单独的行中，但我们将它们视为单个事务。

我有一个用户表单来向我们的管理团队提交任务，该用户表单由每行特定单元格中可见的命令按钮调用。然后我使用ActiveCell.Row 预先填写一些表单详细信息。 它有一个复选框来指示任务何时适用于所有策略，还有一个消息框告诉用户有多少策略。 我已经使用此代码来做到这一点

Dim strCount As String
strCount = Application.WorksheetFunction.CountIf(Range("C:C"), TxtClient.Value)

这可以正常工作并返回正确的值，但是我还需要搜索 D:D 列以匹配续订日期，并且只计算与两列都匹配的行。

稍后在我的代码中，我还需要遍历与客户名称和续订日期匹配的所有这些行，并在 A 列中添加一个请求 ID。

我整天都在寻找解决这个问题的方法，结果空手而归。谁能指出我正确的方向？

Answer 1

如果不需要初步计数，请测试下一个（简单）代码：

Sub testFindMatching()
   Dim sh As Worksheet, lastRow As Long, i As Long
   Dim strCriteria As String

   Set sh = ActiveSheet
   lastRow = sh.Range("C" & Rows.Count).End(xlUp).row
   strCriteria = TxtClient.Value & CStr(DateValue(txtSomethingElse.Value)) 'use here your appropriate source for 'SomethingElse'
   For i = 2 To lastRow
      If sh.Range("C" & i).Value & sh.Range("D" & i).Value = _
                   strCriteria Then sh.Range("A" & i).Value = "RqID" 'Your "request ID" to be filled in A:A
   Next i
End Sub

如果要处理的范围很大，我也可以使用数组发布更快的版本。

事实上，更快的变体在任何情况下都可以很好地工作。我也会放第一个版本，对数组不太熟悉的人很容易理解：

Sub testFindMatching_Arrays()
   Dim sh As Worksheet, lastRow As Long, i As Long
   Dim arr As Variant, arrFin As Variant, strCriteria As String

   Set sh = ActiveSheet
   lastRow = sh.Range("C" & Rows.Count).End(xlUp).row
   arr = sh.Range("C2:D" & lastRow).Value
   ReDim arrFin(1 To UBound(arr, 1), 1 To 1)
   strCriteria = TxtClient.Value & CStr(DateValue(txtSomethingElse.Value)) 'use here your appropriate source for 'SomethingElse'
   For i = 1 To UBound(arr, 1)
      If arr(i, 1) & arr(i, 2) = strCriteria Then
          arrFin(i, 1) = "RqID" 'Your "request ID" to be filled in A:A
      Else
          arrFin(i, 1) = sh.Range("A" & i + 1).Value
      End If
   Next i
   sh.Range("A2:A" & lastRow).Value = arrFin
End Sub

已编辑：将代码调整为也可以使用第二个参数 (As Date)。

Answer 2

此代码在 A 列和 B 列中创建一个随机的 A 或 B，并比较它们以查看它们是否相同，然后突出显示它们。

For Each cel In Range("a1:a15")
  cel.Value = Chr(65 + Int(Rnd * 2))
  cel.Offset(0, 1) = Chr(65 + Int(Rnd * 2))
    If cel = cel.Offset(0, 1) Then
      cel.Interior.Color = RGB(220, 210, 210)
      cel.Offset(0, 1).Interior.Color = RGB(220, 210, 210)
    End If
Next cel

Answer 3

我希望我能理解这个任务。请找到以下解决方案。我希望您可以根据您的最终目标对其进行修改。我还在下一个 sub 中包含了一个如何调用它的示例。请让我知道它是否适合您。谢谢。

Sub SelectPolicies(TxtClient As String, dPolicyDate As Date)
    'The following three ranges are covering the part of C and D columns filled with data and the whole A column
    Dim rngClientNames As Range
    Dim rngPolicyDates As Range
    Dim rngOutputID As Range
    With ThisWorkbook.Sheets("Policies")
        Set rngClientNames = .Range("C1:C" & .Range("C" & .Rows.Count).End(xlUp).Row)
        Set rngPolicyDates = .Range("D1:D" & .Range("D" & .Rows.Count).End(xlUp).Row)
        Set rngOutputID = .Range("A:A")
    End With
    Dim i As Long
    For i = 1 To rngClientNames.Rows.Count 'Looping throug all the rows

        If rngClientNames(i).Value = TxtClient And rngPolicyDates(i).Value = dPolicyDate Then
            'If the client and the policy date (renewal) is matching write the client into A column
            rngOutputID(i).Value = TxtClient
        Else
            'if not matching, empty the relevant row in A column
            rngOutputID(i).Value = ""
        End If
    Next i
End Sub

Sub Test()
    'Call the sub with the actual TxtClient and renewal Date.
    'In the test these are in the K1 and L1 cells
    Call SelectPolicies(Range("K1").Value, Range("L1").Value)
End Sub