excel - 将动态范围与另一个工作簿中的动态范围进行比较并获得价值

Question

我想将四个单元格值与另一张表中的动态范围进行比较。我在另一个工作簿中比较的四个单元格值是员工 ID、工资率、部门和客户 ID。如果它们匹配返回值。

我只想使用 VBA 代码，因为我以前使用过一个公式。

我使用的公式如下：

=INDEX($L$2:$V$60000, MATCH(1,  (C2=$O$2:$O$60000) * (D2=$P$2:$P$60000) * (E2=$Q$2:$Q$60000) * (f2=$r$2:$r$60000),0),10)

这个公式是手动更新的，我要比较的数据必须将其粘贴到工作簿中，该工作簿中的数据具有我想要提取的值。该值位于第 10 列。

请帮我自动化这一步。如果我不够清楚，请告诉我。另外，如果可能的话，我只想使用语句而不是应用程序函数。

提前感谢大家。

Option Explicit

Public Function MatchData() As Variant
On Error GoTo Proc_Error

    Dim rngData             As Excel.Range
    Dim scpData             As Scripting.Dictionary

    Dim arrNeed             As Variant
    Dim arrDates            As Variant
    Dim arrResult           As Variant

'    Dim path                As String
    Dim lngRow              As Long
    Dim intCol              As Integer
    Dim strLookup           As String
    Dim strReturn           As String

' load the GetDates data into an array. Function looks for source worksheet, starting row, number of columns to return and starting column
    arrDates = GetData(wsGetDates, 2, 4, 4)      '(start with Row 2, column 4, return 8 columns)
' build a scripting dictionary object over the array, starting with column 1 for four columns. Use a period as a delimiter.  Essentially an index over the array
    Set scpData = Loadscp(arrDates, 1, 4, ".")

' put the values to find into another array.
    arrNeed = GetData(wsNeedDates, 2, 4, 3)   '(start with Row 2, column 3, return 4 columns)
    ReDim arrResult(LBound(arrNeed, 1) To UBound(arrNeed, 1), 1 To 2)

' Loop through the data needing dates to find matching rows in GetDates
    For lngRow = LBound(arrNeed, 1) To UBound(arrNeed, 1)
    ' build a key matching the index built above
        strLookup = arrNeed(lngRow, LBound(arrNeed, 2))
        For intCol = LBound(arrNeed, 2) + 1 To UBound(arrNeed, 2)
            strLookup = strLookup & "." & arrNeed(lngRow, intCol)
        Next intCol

    ' if the key is found in the index, return the corresponding value in the 7th column (U)
        If scpData.Exists(strLookup) Then
            arrResult(lngRow, 1) = arrDates(scpData.Item(strLookup), 7)
            arrResult(lngRow, 2) = arrDates(scpData.Item(strLookup), 8)
        Else
            arrResult(lngRow, 1) = "No Match"
            arrResult(lngRow, 2) = "No Match"
        End If
    Next lngRow

' Finally, push the results back to the sheet needing the data
    wsNeedDates.Range("I2").Resize(UBound(arrResult, 1) - LBound(arrResult, 1) + 1, _
        UBound(arrResult, 2) - LBound(arrResult, 2) + 1).Value = arrResult

Proc_Exit:

' clean up all the objects
    Set wbNeedDates = Nothing
    Set wsNeedDates = Nothing
    Set wsGetDates = Nothing
    Set wbGetDates = Nothing
    Set scpData = Nothing
    Set rngData = Nothing

    Exit Function

Proc_Error:

    Select Case Err
        Case Else
            MsgBox "Error " & CStr(Err) & ": " & Err.Description
            Resume Proc_Exit
    End Select

End Function
'I normally put these in a separate utility module, they just get in the way of me looking at the logic...

Public Function GetData(ByVal wksCurr As Excel.Worksheet, Optional ByVal intTop As Integer = 1, _
    Optional ByVal intCols As Integer = 1, Optional intCol As Integer = 1) As Variant
On Error GoTo Proc_Error

    Dim arrTemp             As Variant

Dim lngLastRow          As Long

    lngLastRow = LastRow(wksCurr, intCol)

    If lngLastRow >= intTop Then
        GetData = wksCurr.Cells(intTop, intCol).Resize(lngLastRow - intTop + 1, intCols).Value
    Else
        ReDim arrTemp(1 To 1, 1 To intCols)
        GetData = arrTemp
    End If

Proc_Exit:

    Exit Function

Proc_Error:

    Select Case Err
        Case Else
            MsgBox "Error " & CStr(Err) & ": " & Err.Description
            Resume Proc_Exit
    End Select

    Exit Function

End Function

Public Function LastRow(ByVal wksCurr As Excel.Worksheet, ByVal intCol As Integer) As Long

    Dim lngLastRow          As Long

    On Error Resume Next
    lngLastRow = wksCurr.Columns(intCol).Find( _
        What:="*", After:=wksCurr.Cells(1, intCol), _
        MatchCase:=False, _
        LookAt:=xlPart, LookIn:=xlValues, _
        SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).row
    If Err <> 0 Then
        lngLastRow = 0
        Err.Clear
    End If

    LastRow = lngLastRow

End Function

Public Function Loadscp(ByVal varList As Variant, Optional ByVal intCol As Integer = 1, _
    Optional ByVal intCols As Integer = 1, Optional ByVal strDelim As String = ".") As Scripting.Dictionary

    Dim scpList             As Scripting.Dictionary

    Dim arrVals             As Variant

    Dim lngLastRow          As Long
    Dim lngRow              As Long
    Dim intABSCol           As Integer
    Dim intColCurr          As Integer
    Dim strVal              As String
    Dim intRngCol           As Integer

    Set Loadscp = New Scripting.Dictionary
    Loadscp.CompareMode = vbTextCompare

    intABSCol = Abs(intCol)
    If IsArray(varList) Then
        arrVals = varList
    ElseIf TypeName(varList) = "Range" Then
        intRngCol = varList.Column
        lngLastRow = LastRow(varList.Parent, intCol)

        If lngLastRow > varList.row Then
            arrVals = varList.Offset(1, intABSCol - 1).Resize(lngLastRow - varList.row, 1)
        End If
    ElseIf TypeName(varList) = "Dictionary" Then
        Set scpList = varList
        ReDim arrVals(1 To scpList.count, 1 To 1)
        For lngRow = 1 To scpList.count
            arrVals(lngRow, 1) = scpList.Keys(lngRow - 1)
        Next lngRow
    End If

    If IsArray(arrVals) Then
        For lngRow = LBound(arrVals, 1) To UBound(arrVals, 1)
            strVal = arrVals(lngRow, intCol)
            For intColCurr = intCol + 1 To intCol + intCols - 1
                strVal = strVal & strDelim & arrVals(lngRow, intColCurr)
            Next intColCurr
            If Not Loadscp.Exists(strVal) Then
                Loadscp.Item(strVal) = lngRow
            End If
        Next lngRow
    End If

End Function

标签： excelvba

Answer 1

不知道你想如何实现这一点，你没有提供太多信息。一些 VBA 可能会这样做，返回 O 列中的匹配值：

首先，在VBA编辑器中，选择Tools，References，勾选Microsoft Scripting Runtime；你需要这个脚本库。

匹配事物的逻辑在第一个例程中。

Option Explicit

Public Function MatchData() As Variant
On Error GoTo Proc_Error

    Dim wbNeedDates         As Workbook
    Dim wbGetDates          As Workbook
    Dim wbNeedDates         As Worksheet
    Dim wsGetDates          As Worksheet
    Dim rngData             As Excel.Range
    Dim scpData             As Scripting.Dictionary

    Dim arrNeed             As Variant
    Dim arrDates            As Variant
    Dim arrResult           As Variant

'    Dim path                As String
    Dim lngRow              As Long
    Dim intCol              As Integer
    Dim strLookup           As String
    Dim strReturn           As String

'    path = "C:\Users\works\Documents\Macros\"
    Set wbNeedDates = Workbooks("Need Dates.xlsx")
    Set wsNeedDates = wbNeedDates.Worksheets("Inactive4Weeks copy")

    Set wbGetDates = Workbooks("Copy of TransactionExportReport.xlsx")
    Set wsGetDates = wbGetDates.Worksheets("TransactionExportReport")

' load the GetDates data into an array. Function looks for source worksheet, starting row, number of columns to return and starting column
    arrDates = GetData(wsGetDates, 2, 8, 4)      '(start with Row 2, column 4, return 8 columns)
' build a scripting dictionary object over the array, starting with column 1 for four columns. Use a period as a delimiter.  Essentially an index over the array
    Set scpData = Loadscp(arrDates, 1, 4, ".")

' put the values to find into another array.
    arrNeed = GetData(wsNeedDates, 2, 4, 3)   '(start with Row 2, column 3, return 4 columns)
    ReDim arrResult(LBound(arrNeed, 1) To UBound(arrNeed, 1), 1 To 2)

' Loop through the data needing dates to find matching rows in GetDates
    For lngRow = LBound(arrNeed, 1) To UBound(arrNeed, 1)
    ' build a key matching the index built above
        strLookup = arrNeed(1, LBound(arrNeed, 2))
        For intCol = LBound(arrNeed, 2) + 1 To UBound(arrNeed, 2)
            strLookup = strLookup & "." & arrNeed(1, intCol)
        Next intCol

    ' if the key is found in the index, return the corresponding value in the 7th column (U)
        If scpData.Exists(strLookup) Then
            arrResult(lngRow, 1) = arrDates(scpData.Item(strLookup), 7)
            arrResult(lngRow, 2) = arrDates(scpData.Item(strLookup), 8)
        Else
            arrResult(lngRow, 1) = "No Match"
            arrResult(lngRow, 2) = "No Match"
        End If
    Next lngRow

' Finally, push the results back to the sheet needing the data
    wbNeedDates.Range("I2").Resize(UBound(arrResult, 1) - LBound(arrResult, 1) + 1, _
        UBound(arrResult, 2) - LBound(arrResult, 2) + 1).Value = arrResult

Proc_Exit:

' clean up all the objects
    Set wbNeedDates = Nothing
    Set wsGetDates = Nothing
    Set wbNeedDates = Nothing
    Set wbGetDates = Nothing
    Set scpData = Nothing
    Set rngData = Nothing

    Exit Function

Proc_Error:

    Select Case Err
        Case Else
            MsgBox "Error " & CStr(Err) & ": " & Err.Description
            Resume Proc_Exit
    End Select

End Function

我通常将它们放在一个单独的实用程序模块中，它们只是妨碍我查看逻辑......

Public Function GetData(ByVal wksCurr As Excel.Worksheet, Optional ByVal intTop As Integer = 1, _
    Optional ByVal intCols As Integer = 1, Optional intCol As Integer = 1) As Variant
On Error GoTo Proc_Error

    Dim arrTemp             As Variant

    Dim lngLastRow          As Long

    lngLastRow = LastRow(wksCurr, intCol)

    If lngLastRow >= intTop Then
        GetData = wksCurr.Cells(intTop, intCol).Resize(lngLastRow - intTop + 1, intCols).Value
    Else
        ReDim arrTemp(1 To 1, 1 To intCols)
        GetData = arrTemp
    End If

Proc_Exit:

    Exit Function

Proc_Error:

    Select Case Err
        Case Else
            MsgBox "Error " & CStr(Err) & ": " & Err.Description
            Resume Proc_Exit
    End Select

    Exit Function

End Function

Public Function LastRow(ByVal wksCurr As Excel.Worksheet, ByVal intCol As Integer) As Long

    Dim lngLastRow          As Long

    On Error Resume Next
    lngLastRow = wksCurr.Columns(intCol).Find( _
        What:="*", After:=wksCurr.Cells(1, intCol), _
        MatchCase:=False, _
        LookAt:=xlPart, LookIn:=xlValues, _
        SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Row
    If Err <> 0 Then
        lngLastRow = 0
        Err.Clear
    End If

    LastRow = lngLastRow

End Function

Public Function Loadscp(ByVal varList As Variant, Optional ByVal intCol As Integer = 1, _
    Optional ByVal intCols As Integer = 1, Optional ByVal strDelim As String = ".") As Scripting.Dictionary

    Dim scpList             As Scripting.Dictionary

    Dim arrVals             As Variant

    Dim lngLastRow          As Long
    Dim lngRow              As Long
    Dim intABSCol           As Integer
    Dim intColCurr          As Integer
    Dim strVal              As String
    Dim intRngCol           As Integer

    Set Loadscp = New Scripting.Dictionary
    Loadscp.CompareMode = vbTextCompare

    intABSCol = Abs(intCol)
    If IsArray(varList) Then
        arrVals = varList
    ElseIf TypeName(varList) = "Range" Then
        intRngCol = varList.Column
        lngLastRow = LastRow(varList.Parent, intCol)

        If lngLastRow > varList.Row Then
            arrVals = varList.Offset(1, intABSCol - 1).Resize(lngLastRow - varList.Row, 1)
        End If
    ElseIf TypeName(varList) = "Dictionary" Then
        Set scpList = varList
        ReDim arrVals(1 To scpList.Count, 1 To 1)
        For lngRow = 1 To scpList.Count
            arrVals(lngRow, 1) = scpList.Keys(lngRow - 1)
        Next lngRow
    End If

    If IsArray(arrVals) Then
        For lngRow = LBound(arrVals, 1) To UBound(arrVals, 1)
            strVal = arrVals(lngRow, intCol)
            For intColCurr = intCol + 1 To intCol + intCols - 1
                strVal = strVal & strDelim & arrVals(lngRow, intColCurr)
            Next intColCurr
            If Not Loadscp.Exists(strVal) Then
                Loadscp.Item(strVal) = lngRow
            End If
        Next lngRow
    End If

End Function