VBA循环遍历2个不同大小的范围
Posted
技术标签:
【中文标题】VBA循环遍历2个不同大小的范围【英文标题】：VBA Looping through 2 different sized ranges 【发布时间】：2014-05-13 07:55:11 【问题描述】：甚至不确定它是否可能或它背后的逻辑（上周才开始使用 VBA），但我需要帮助来循环遍历两个不同大小但具有相似 ID 的不同范围。
在一张纸上，我有大约 1500 行，大约 700 个唯一 ID，在第二张纸上，我有 650 行，都是唯一的。我现在遇到的问题是，它会遍历 650 行，但由于第一行中有额外的唯一 ID，我的长度大约为 100。
到目前为止，我的代码如下，可能还有其他一些问题，或者我正在做的事情可能会导致不同的问题，但仍在学习，因此我们将不胜感激。
哦，我可以通过将 compare3 改回 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
【问题讨论】：
【参考方案1】：我可以建议您使用 Scripting.Dictionary 对象吗？在您的 VBA IDE 中，转到菜单 Tools->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
【讨论】：
【参考方案2】：我自己现在就开始工作了。以防万一其他人将来需要它。代码如下。
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 aCellUnique As Range
Dim x As Integer
x = 1
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 = ws1.Range(Split(ws1.Cells(, aCellComparison.Column).Address, "$")(1) & ws1.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(lRow2, 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
x = x + 1
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, aCellComparison1.Column).Value
If ((x > 2) And (comparison <> comparison3)) Then
a = a + 1
comparison3 = ws1.Cells(a, aCellComparison.Column).Value
comparison4 = ws1.Cells(a, aCellComparison1.Column).Value
End If
If comparison <> comparison3 Then
Do Until comparison = comparison3
x = x + 1
comparison = ws.Cells(x, aCell.Column).Value
comparison1 = ws.Cells(x, aCell1.Column).Value
comparison2 = ws.Cells(x, aCell3.Column).Value
Loop
End If
Range("J" & x).Select
Application.CutCopyMode = False
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
Next
End If
End If
End With
End Function
【讨论】：
以上是关于VBA循环遍历2个不同大小的范围的主要内容，如果未能解决你的问题，请参考以下文章
Excel VBA - 循环遍历多个文件夹中的文件，复制范围，粘贴到此工作簿中