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

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

Answer 1

不确定您要如何实现它，您没有提供太多信息。可能会执行的一些VBA，在O列中返回匹配值：

首先，在VBA编辑器中，选择“工具”，“引用”，然后检查“ 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