Excel VBA 比较两个二维数组的有效方法
Excel VBA efficient way to compare two 2D arrays
我有两个二维数组(我们称它们为 A 和 B),都在元素 0 处包含序列号,在元素 1 处包含日期。A 中的许多序列号都可以在 B 中找到(大约 60%)。如果匹配,我需要检查数组 B 中的相应日期是否小于数组 A 中的日期,如果是,则将 A 中的日期设置为空。
目前我正在循环中使用循环:
For x = 0 To UBound(arrayA)
For y = 0 To UBound(arrayB)
If arrayB(y, 0) = arrayA(x, 0) Then ' the serial numbers match
If arrayB(y, 1) < arrayA(x, 1) Then ' test the dates
arrayA(x, 1) = Null
End If
Exit For
End If
Next y
Next x
这很好但很慢(大约 30 - 40 秒)所以我一直在尝试设计其他方法,其中一些非常古怪,例如
dateB = application.Vlookup(arrayB, arrayA(x), 1, false
这需要两倍的时间,您需要处理未发现的错误。
我已经尝试创建两个一维数组(序列号、日期)而不是二维数组 B 并使用 application.match 提供日期索引,但这同样需要大约两倍的时间才能完成。最后,我尝试将数据写入工作表,通过 vlookup 获取日期并比较它们,但这并没有更快,也不是我真正想要的。
任何想法表示赞赏。
这是一些基于序列号比较日期的框架。
Sub dictCompare()
Dim a As Long, arrA As Variant, arrB As Variant, dictB As Object
Debug.Print Timer
Set dictB = CreateObject("scripting.Dictionary")
dictB.comparemode = vbTextCompare
With Worksheets("sheet1")
With Intersect(.UsedRange, .Range("A:B"))
arrA = .Cells.Value2
End With
End With
With Worksheets("sheet2")
With Intersect(.UsedRange, .Range("A:B"))
arrB = .Cells.Value2
End With
For a = LBound(arrB, 1) + 1 To UBound(arrB, 1) 'LBound(arrB, 1)+1 to skip the column header label
dictB.Item(arrB(a, 1)) = arrB(a, 2)
Next a
End With
For a = LBound(arrA, 1) + 1 To UBound(arrA, 1) 'LBound(arrA, 1)+1 to skip the column header label
If dictB.exists(arrA(a, 1)) Then
If dictB.Item(arrA(a, 1)) > arrA(a, 2) Then _
arrA(a, 2) = vbNullString
End If
Next a
With Worksheets("sheet1")
.Cells(1, 1).Resize(UBound(arrA, 1), UBound(arrA, 2)) = arrA
End With
Debug.Print Timer
End Sub
适当调整工作表和范围。虽然计时结果非常主观,但对于 Sheet1 和 Sheet2 中的 30K 行随机数据,这需要大约 1⁄3 秒。
我有两个二维数组(我们称它们为 A 和 B),都在元素 0 处包含序列号,在元素 1 处包含日期。A 中的许多序列号都可以在 B 中找到(大约 60%)。如果匹配,我需要检查数组 B 中的相应日期是否小于数组 A 中的日期,如果是,则将 A 中的日期设置为空。
目前我正在循环中使用循环:
For x = 0 To UBound(arrayA)
For y = 0 To UBound(arrayB)
If arrayB(y, 0) = arrayA(x, 0) Then ' the serial numbers match
If arrayB(y, 1) < arrayA(x, 1) Then ' test the dates
arrayA(x, 1) = Null
End If
Exit For
End If
Next y
Next x
这很好但很慢(大约 30 - 40 秒)所以我一直在尝试设计其他方法,其中一些非常古怪,例如
dateB = application.Vlookup(arrayB, arrayA(x), 1, false
这需要两倍的时间,您需要处理未发现的错误。
我已经尝试创建两个一维数组(序列号、日期)而不是二维数组 B 并使用 application.match 提供日期索引,但这同样需要大约两倍的时间才能完成。最后,我尝试将数据写入工作表,通过 vlookup 获取日期并比较它们,但这并没有更快,也不是我真正想要的。
任何想法表示赞赏。
这是一些基于序列号比较日期的框架。
Sub dictCompare()
Dim a As Long, arrA As Variant, arrB As Variant, dictB As Object
Debug.Print Timer
Set dictB = CreateObject("scripting.Dictionary")
dictB.comparemode = vbTextCompare
With Worksheets("sheet1")
With Intersect(.UsedRange, .Range("A:B"))
arrA = .Cells.Value2
End With
End With
With Worksheets("sheet2")
With Intersect(.UsedRange, .Range("A:B"))
arrB = .Cells.Value2
End With
For a = LBound(arrB, 1) + 1 To UBound(arrB, 1) 'LBound(arrB, 1)+1 to skip the column header label
dictB.Item(arrB(a, 1)) = arrB(a, 2)
Next a
End With
For a = LBound(arrA, 1) + 1 To UBound(arrA, 1) 'LBound(arrA, 1)+1 to skip the column header label
If dictB.exists(arrA(a, 1)) Then
If dictB.Item(arrA(a, 1)) > arrA(a, 2) Then _
arrA(a, 2) = vbNullString
End If
Next a
With Worksheets("sheet1")
.Cells(1, 1).Resize(UBound(arrA, 1), UBound(arrA, 2)) = arrA
End With
Debug.Print Timer
End Sub
适当调整工作表和范围。虽然计时结果非常主观,但对于 Sheet1 和 Sheet2 中的 30K 行随机数据,这需要大约 1⁄3 秒。