Excel VBA 使用非唯一字符串值和布尔数据有效地更新日期

Question

我正在 VBA 中为 Excel 寻找一种比数组更快的方法来更新数据中的日期。我试过使用 scripting.dictionary 但卡住了。示例数据和当前可用的代码如下。

serial 的值不唯一。因此目前认为这些需要循环两次以考虑每一行。

代码的objective是当serial和boolean1的值匹配时，设置dates1为dates2的值是 1，然后将其输出回 sheet。

目前有超过 125000 行数据，这将在接下来的几个月内逐渐增加。

只有一行具有独特的 serial 并且还具有 boolean1 of 1.

目前以下代码在 i7 处理器上需要 8 分钟。 主要目的是尽可能减少这个时间。索引匹配公式可能更快，但也寻找其他解决方案，如字典、集合等

示例输入数据：

serial    boolean1    dates2    dates1
ABC001    0    01/01/19    
ABC002    0    02/01/19    
ABC003    0    03/01/19    
ABC004    0    02/01/19 
ABC005    0    02/01/19   
ABC001    1    11/01/19    
ABC002    1    12/01/19    
ABC003    1    13/01/19    
ABC004    1    12/01/19

预期输出数据：

serial    boolean1    dates2   dates1
ABC001    0    01/01/19    11/01/19      
ABC002    0    02/01/19    12/01/19   
ABC003    0    03/01/19    13/01/19   
ABC004    0    02/01/19    12/01/19 
ABC005    0    02/01/19  
ABC001    1    11/01/19    11/01/19    
ABC002    1    12/01/19    12/01/19 
ABC003    1    13/01/19    13/01/19 
ABC004    1    12/01/19    12/01/19

当前代码：

serial() = sheetnm1.Range("serial_nr").Value 
boolean1() = sheetnm1.Range("boolean_nr").Value
dates1() = sheetnm1.Range("dates1_nr").Value
dates2() = sheetnm1.Range("dates2_nr").Value

y = 1
For x = 1 To UBound(boolean1, 1)
    If boolean1(x, 1) = 1 Then
        For y = 1 To UBound(boolean1, 1)
            If serial(y, 1) = serial(x, 1) Then
                dates1(y, 1) = dates2(x, 1)
            End If
        Next y
    End If
Next x

sheetnm1.Range("dates1_nr") = dates1

Answer 1

如果您的 boolean1 始终为 0 或 1，则应该这样做：

Option Explicit
Sub Test()

    Dim MyArr As Variant
    Dim DictDates As New Scripting.Dictionary
    Dim i As Long

    With ThisWorkbook.Sheets("MySheet") 'change MySheet for your sheetname
        MyArr = .UsedRange.Value 'store the whole sheet inside the array
        'loop through row 2 to last row to store data inside the dictionary
        For i = 2 To UBound(MyArr)
            'Check if the concatenate Serial & boolean doesn't already exists and add it giving the date as item
            If Not DictDates.Exists(MyArr(i, 1) & MyArr(i, 2)) Then
                DictDates.Add MyArr(i, 1) & MyArr(i, 2), MyArr(i, 3)
            End If
        Next i
        'loop through row 2 to last row to fill the data for boolean1 = 0
        For i = 2 To UBound(MyArr)
            'Check if the boolean1 = 0 and if the serial with boolean = 1 exists in your dictionary
            If MyArr(i, 2) = 0 And DictDates.Exists(MyArr(i, 1) & 1) Then
                MyArr(i, 4) = DictDates(MyArr(i, 1) & 1)
            'for boolean1 = 1 copies the date2 to date1
            ElseIf MyArr(i, 2) = 1 Then
                MyArr(i, 4) = MyArr(i, 3)
            End If
        Next i
        .UsedRange.Value = MyArr
    End With

End Sub

Answer 2

除非有一些其他的边缘情况（例如，一个 Serial 仅存在布尔值 = 1 但不 0），我认为这可以通过工作表公式来完成。假设 A 列中的序列号等：

=IF(COUNTIF($A:$A,$A2)=2,IFERROR(VLOOKUP($A2,$A3:$C,3,FALSE),C2),"")

Excel VBA 使用非唯一字符串值和布尔数据有效地更新日期

Excel VBA updating dates efficiently with non-unique string values and boolean data

excel

performance

time

vba

coding-efficiency