要匹配的子

Question

出于某些原因，我无法评论。下面的答案都给了我各种错误，因为activex无法创建对象未定义的对象。

这是我的代码。

Sub Main()
Application.ScreenUpdating = False

Dim stNow As String
stNow = Now


Set sh1 = ThisWorkbook.Worksheets("StrategyIn")
Set sh2 = ThisWorkbook.Worksheets("Contractor")

Dim arr As Variant
arr = sh1.Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row).Value



Dim varr As Variant
varr = sh2.Range("E2:E" & Range("E" & Rows.Count).End(xlUp).Row).Value


Dim temp As Integer
temp = 0


Dim x As Variant, y As Variant, Match As Boolean
For Each x In arr
    Match = False
    For Each y In varr
        If x = y Then Match = True
    Next y
    If Not Match Then
    temp = temp + 1
    End If
Next

MsgBox "Number of names that do not match = " & temp
    'Debug.Print DateDiff("s", stNow, Now)
Application.ScreenUpdating = True
End Sub

当我删除对其他工作表的引用以获取范围时，它工作正常，当我在一张纸上并且数据全部收集在一张纸上时，它可以正常工作。有一个逻辑错误导致我得到一些不匹配的名称= 1。谢谢你的帮助！

Answer 1

要匹配的子

Sub Match()  

Dim WksS as Range, WksC as Range
Dim stNow as String
Dim rSI as Range, rCon as Range
Dim iLR as Integer, iTemp as Variant, vVal as Variant

Set WksS = Worksheets("StrategyIn")
Set WksC = Worksheets("Contractor")
Set rSI = WksS.Range("A2", WksS.Range("A2").End(xlDown))
Set rCon = WksC.Range("E2", WksC.Range("E2").End(xlDown))
stNow = Now()

iLR = WksC.Range("A2").End(xlDown).Row '' "lastrow"
iTemp = 0

'' Because is only one column you dont need to create an array
For Each vVal in rCon 
    iTemp = iTemp + IIF(Fun_Val(vVal,rCon),1,0)
Next vVal

iTemp = (iTemp/iLR)*100

MsgBox "Percentage difference = " & temp & "%"

Exit Sub

验证功能

Function Fun_Val(dVal As Double, rRange As Range) As Boolean  

On Error GoTo errHdlr  

    Fun_Val = IsNumeric(Application.WorksheetFunction.Match(dVal, rRange, 0))  

    Exit Function  
    errHdlr:  
    Fun_Val = False  

End Function

顺便说一句，您应该考虑更改设置变量的方式。

范围
arr = Range("B2:B" & Range("B"&Rows.Count).End(xlUp).Row).Value到
arr = Range("B2", Range("B2").End(xlDown))
宣言
Dim x, y, Match As Boolean到
Dim x as Variant, y as Variant, Match As Boolean
工作表
Worksheets("StrategyIn")
到
Dim Wks as Worksheet
Set Wks = Worksheets("StrategyIn")
这样可以避免工作表之间的错误

Answer 2

您可以在Range变量中指定范围引用的工作表。

Sub Match()

'Call Concatenate

Application.ScreenUpdating = False

Dim stNow As String
stNow = Now

Dim arr As Range
Set arr = Worksheets("StrategyIn").Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Value


Dim varr As Range
Set varr = Worksheets("Contractor").Range("E2:E" & Range("E" & Rows.Count).End(xlUp).Row).Value


Dim temp As Double
temp = 0

With Worksheets("StrategyIn")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

Worksheets("Contractor").Select
Dim x, y, Match As Boolean

For Each x In arr

    Match = False
        For Each y In varr
            If x = y Then Match = True
Next y

    If Not Match Then
        temp = temp + 1
    End If

Next
   'temp = (temp / lastrow) * 100

MsgBox "Percentage difference = " & temp & "%"

Application.ScreenUpdating = True
End Sub

Answer 3

不确定为何在代码中使用范围A StrategIn 。您可以使用.NET's Collection ArrayList快速检入数组中的项目。

下面的代码将适合您的使用，如果您在两列中都有非常大的数据集，那也没关系。我更改了 立即窗口 中的差异的最终显示，而不是 MsgBox ，用于表格输出。

Option Explicit

Sub ShowDifferences()
    Dim aColB As Variant, aColE As Variant ' Memory allocations for the range values
    Dim oItem As Variant
    Dim oListB As Object, oListE As Object, oTemp As Object ' Arraylist Objects from .NET

    ' Create Collections from .NET
    Set oListB = CreateObject("System.Collections.ArrayList")
    Set oListE = CreateObject("System.Collections.ArrayList")
    Set oTemp = CreateObject("System.Collections.ArrayList")

    ' Load the ranges into memory array
    With ThisWorkbook.Worksheets("StrategyIn")
        aColB = .Range("B2:B" & .Range("B" & Rows.Count).End(xlUp).Row).Value
    End With
    With ThisWorkbook.Worksheets("Contractor")
        aColE = .Range("E2:E" & .Range("E" & Rows.Count).End(xlUp).Row).Value
    End With

    ' Add these data to the ArrayList
    For Each oItem In aColB
        If Not oListB.Contains(oItem) Then oListB.Add oItem
    Next
    For Each oItem In aColE
        If Not oListE.Contains(oItem) Then oListE.Add oItem
    Next

    ' Free memory of Range values
    Set aColB = Nothing
    Set aColE = Nothing

    ' Compare the differences (different if each B not found in E)
    For Each oItem In oListB
        If Not oListE.Contains(oItem) Then oTemp.Add oItem
    Next

    ' Display the result
    Debug.Print "B-items", "E-items", "Differences (#Diff/#B)"
    Debug.Print oListB.Count, oListE.Count, oTemp.Count & Format(oTemp.Count / oListB.Count, " (0%) ") & Join(oTemp.ToArray, "|")

    ' CleanUp
    oListB.Clear
    oListE.Clear
    oTemp.Clear
    Set oListB = Nothing
    Set oListE = Nothing
    Set oTemp = Nothing
End Sub

Answer 4

我尝试过不同的解决方案，它对我的数据起作用。但我不确定这是不是你想要的。

Sub mismatch()

Dim Lastrow_StrategyIn As Integer, temp As Integer
Dim strg As Worksheet, contr As Worksheet

Set strg = Worksheets("StrategyIn")
Set contr = Worksheets("Contractor")

Lastrow_StrategyIn = strg.Range("A65555").End(3).Row


For i = 2 To Lastrow_StrategyIn
    strg.Cells(i, 2) = Application.IfError(Application.VLookup(strg.Cells(i, 1), contr.Range("A:A"), 1, 0), "")
    If strg.Cells(i, 2) = "" Then
        temp = temp + 1
    End If

Next
MsgBox (temp / (Lastrow_StrategyIn - 1)) * 100 & "%"

End Sub

Answer 5

希望这对你有用。

Sub Main()
    Dim match As Boolean
    Dim temp As Long
    Dim blankcount As Long
    Dim lastrowS As Long
    Dim lastrowC As Long
    match = False
    lastrowS = Worksheets("StrategyIn").Range("B" & Rows.Count).End(xlUp).Row
    lastrowC = Worksheets("Contractor").Range("E" & Rows.Count).End(xlUp).Row
    With Worksheets("StrategyIn")
        For i = 2 To lastrowS
            If .Range("B" & i).Value <> "" Then
                For j = 2 To lastrowC
                    If .Range("B" & i).Value = Worksheets("Contractor").Range("E" & j).Value Then
                        match = True
                    End If
                Next j
            Else
                blankcount = blankcount + 1
            End If
            If match = False Then
                temp = temp + 1
            Else
                match = False
            End If
        Next i
    End With
    MsgBox "Number of names that do not match = " & (temp - blankcount)
End Sub

工作证明

2个工作表之间的字符串列的精确比较excel vba

5 个答案:

要匹配的子

验证功能