'稍作修改,自己测试一下。如果可用把总数据行与运行时间给我传上来
'你这点数据不带输出用时100ms左右,每个ID仅匹配一次,,,
Option Explicit
Const NUM As Long = 5 * 10 ^ 4 '每个字典最多装入的数据条数
Const LINE As Long = 10 ^ 5 '分段读取数据,这里10^5行为一段,如果溢出可以改的更小些,比如5*10^4
Sub test()
Dim arr(), t As String, i As Long, j As Long, k As Long, kk As Long
Dim cnt As Long, m As Long, tm As Single, n As Long, ii As Long
Dim row As Long, sht
tm = Timer
With Sheets("4")
arr = .Range("a2:b" & .Cells(Rows.Count, "b").End(xlUp).row).Value
End With
ReDim brr(1 To UBound(arr, 1), 1 To 14) As String
ReDim dic(UBound(arr, 1) / NUM + 1) As Object
For i = 1 To UBound(dic)
Set dic(i) = CreateObject("scripting.dictionary")
Next
sht = Split("北京市,上海市,广东省", ",")
For i = 1 To UBound(arr, 1)
t = arr(i, 2)
If Len(t) Then
If m Mod NUM = 0 Then cnt = cnt + 1
dic(cnt)(t) = i: m = m + 1
End If
brr(i, 1) = arr(i, 1): brr(i, 2) = arr(i, 2)
Next
On Error GoTo errmsg
For i = 0 To UBound(sht)
row = Sheets(sht(i)).Cells(Rows.Count, "b").End(xlUp).row
ReDim pos(1 To row \ LINE + 1, 1 To 2) As Long
For ii = 1 To UBound(pos)
pos(ii, 1) = (ii - 1) * LINE + 1
pos(ii, 2) = ii * LINE
If row <= pos(ii, 2) Then n = ii: pos(ii, 2) = row: Exit For
Next
For ii = 1 To n
arr = Sheets(sht(i)).Cells(pos(ii, 1), "a").Resize(pos(ii, 2), 14).Value
For j = 1 To UBound(arr, 1)
t = arr(j, 2)
If Len(t) Then
For k = 1 To cnt
If dic(k).exists(t) Then
m = dic(k)(t)
For kk = 3 To UBound(arr, 2)
brr(m, kk) = arr(j, kk)
Next
Exit For
End If
Next
End If
Next
Next
Next
Debug.Print Timer - tm
Sheets("4").[a2].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
Debug.Print Timer - tm
Exit Sub
errmsg:
MsgBox "Error:" & vbNewLine & "工作表:" & i & vbNewLine & "行数:" & j + 1
End Sub |