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

我正在寻找一种在VBA for Excel中比数组更快地从数据更新日期的方法。我尝试过使用

脚本编写.字典

，但被卡住了。下面是工作的示例数据和当前代码

serial

的值是非唯一的。因此，目前认为，考虑每一行时，这些需要循环两次

代码的目的是，当序列上存在匹配项且布尔值1为

1

时，将

dates1

设置为

dates2

，然后将其输出回工作表

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

应该只有一行具有唯一的

串行

，并且还具有

1

的

boolean1

目前，以下代码在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

---

如果布尔值1始终为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

---

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

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

---

更新输入和输出数据以显示不匹配的行示例-

ABC005

而不是仅将数组分配给范围（我怀疑这需要时间），请尝试

WorksheetFunction.Transpose

。我发现它的工作速度要快得多。循环块占用的时间实际上会有两个以上的相同序列号吗？e、 例如，一个序列号存在一次boolan=0，但有两个或多个boolan=1的条目？“目前有超过125000行数据，这将在未来几个月内逐渐增加。”听起来是时候使用数据库而不是excel了？我对该框架投赞成票。代码给出了一个编译错误，但修复起来很简单。速度快得多-从8分钟到2秒-谢谢