Question

甚至不确定它是否可能或它背后的逻辑（上周才启动VBA）但我需要帮助来循环两个不同大小但具有相似ID的不同范围。

在一张纸上我有大约1500行，大约700个唯一ID，在第二张纸上我有650行，都是唯一的。我现在遇到的问题是，它会遍历650行，但由于第一行中有额外的唯一ID，我大约有100个。

我到目前为止的代码是在下面，可能是其他一些问题，或者我正在做可能导致不同问题的事情，但仍然在学习，所以任何帮助都会受到赞赏。

哦，我可以通过将比较3更改回Sheet2！R2C1：R700C1来实现它，但我希望我可以使用尽可能少的设置值来使用它。

Atm，我在

上收到错误

 Selection.FormulaArray = _
            "=INDEX(Sheet2!R2C1:R700C7,MATCH(1,(" & comparison & " = " & comparison3 & ")*(" & comparison1 & "= Sheet2!R2C7:R700C7),0),2)"

因为比较3范围的唯一值比比较要少。

Function compare(FieldName As String, FieldName1 As String, FieldName2 As String) As Boolean

Dim wkb As Workbook
Dim ws, ws1 As Worksheet
Dim lRow As Long, lRow1, lRow2 As Long
Dim aCell As Range, rng1 As Range, aCell1 As Range, rng2 As Range, aCell2 As Range, aCell3 As Range
encrypt = True
Dim x As Integer
x = 2
Dim comparison As String
Dim comparison1 As Integer
Dim comparison2 As String
Dim comparison3 As String
Dim comparison4 As Integer
Dim y As Integer
Dim aCellComparison, aCellComparison1, aCellComparison2 As Range
Dim a As Integer
a = 2

 Set wkb = ActiveWorkbook

 With wkb

    Set ws = ActiveSheet
    Set ws1 = wkb.Sheets("Sheet2")

    '~~> Find the cell which has the name
 Set aCell = ws.Range("A1:Z1").Find(FieldName, LookAt:=xlWhole)
 Set aCell1 = ws.Range("A1:Z1").Find(FieldName1, LookAt:=xlWhole)
 Set aCell2 = ws.Range("A1:Z1").Find("HOS_PROC_FIXED_COST", LookAt:=xlWhole)
 Set aCell3 = ws.Range("A1:Z1").Find(FieldName2, LookAt:=xlWhole)
 Set aCellComparison = ws1.Range("A1:Z1").Find("Code", LookAt:=xlWhole)
 Set aCellComparison1 = ws1.Range("A1:Z1").Find("LOS", LookAt:=xlWhole)

  If aCell Is Nothing Then
        compare = False
  End If

  If Not aCell Is Nothing Then
  lRow = ws.Range(Split(ws.Cells(, aCell.Column).Address, "$")(1) &    ws.Rows.Count).End(xlUp).Row
 lRow1 = ws.Range(Split(ws.Cells(, aCell1.Column).Address, "$")(1) & ws.Rows.Count).End(xlUp).Row
 lRow2 = ws.Range(Split(ws.Cells(, aCell2.Column).Address, "$")(1) & ws.Rows.Count).End(xlUp).Row



 Set rng1 = ws.Range(ws.Cells(x, aCell.Column), ws.Cells(lRow, aCell.Column))
 Set rng2 = ws1.Range(ws1.Cells(x, aCellComparison.Column), ws1.Cells(lRow,  aCellComparison.Column))
 If lRow And lRow1 And lRow2 > 1 Then
            '~~> Set your Range


    Columns("J:J").Select
    Selection.Insert Shift:=xlToRight
    y = aCell2.Column
 For Each c In rng1

        comparison = ws.Cells(x, aCell.Column).Value
        comparison1 = ws.Cells(x, aCell1.Column).Value
        comparison2 = ws.Cells(x, aCell3.Column).Value
        comparison3 = ws1.Cells(a, aCellComparison.Column).Value
        comparison4 = ws1.Cells(a, aCellComparison.Column).Value

        Range("J" & x).Select
        Application.CutCopyMode = False


        If ((x > 2) And (comparison <> ws.Cells(x - 1, aCell.Column).Value)) Then
            a = a + 1
        End If

    If comparison2 = "1" Then

     Selection.FormulaArray = _
            "=INDEX(Sheet2!R2C1:R700C7,MATCH(1,(" & comparison & " = " & comparison3 & ")*(" & comparison1 & "= Sheet2!R2C7:R700C7),0),2)"

    ElseIf comparison2 = "2" Then
        Selection.FormulaArray = _
            "=INDEX(Sheet2!R2C1:R700C7,MATCH(1,(" & comparison & "=    Sheet2!R2C1:R700C1)*(" & comparison1 & "= Sheet2!R2C7:R700C7),0),3)"
    ElseIf comparison2 = "3" Then
        Selection.FormulaArray = _
            "=INDEX(Sheet2!R2C1:R700C7,MATCH(1,(" & comparison & "=  Sheet2!R2C1:R700C1)*(" & comparison1 & "= Sheet2!R2C7:R700C7),0),4)"
    ElseIf comparison2 = "6" Then
    Selection.FormulaArray = _
            "=INDEX(Sheet2!R2C1:R700C7,MATCH(1,(" & comparison & "=       Sheet2!R2C1:R700C1)*(" & comparison1 & "= Sheet2!R2C7:R700C7),0),5)"
    End If

    x = x + 1
Next



End If
End If
End With
End Function

Answer 1

我可以建议您使用Scripting.Dictionary对象吗？在VBA IDE中，转到菜单Tools-＆gt; References，然后从可用参考中检查标记为Microsoft Scripting Runtime的库。然后你可以编写如下代码来比较两组代码

Sub T()


    Dim dicFirst As Scripting.Dictionary
    Set dicFirst = New Scripting.Dictionary

    'loop adding numbers from first set
    Dim v
    For Each v In Range("FirstIDs").Cells
        dicFirst.Add v, Empty
    Next v


    Dim dicSecond As Scripting.Dictionary
    Set dicSecond = New Scripting.Dictionary

    'loop adding numbers from second set
    For Each v In Range("SecondIDs").Cells
        dicSecond.Add v, Empty
    Next v

    'to find all ids in first but not second...
    For Each v In dicFirst.Keys
        If Not dicSecond.Exists(v) Then
            Debug.Print v & " in 1 but not 2"
        End If
    Next v

    'to find all ids in second but not first ...
    For Each v In dicSecond.Keys
        If Not dicFirst.Exists(v) Then
            Debug.Print v & " in 2 but not 1"
        End If
    Next v

End Sub

VBA循环通过2个不同大小的范围

1 个答案: