Sub ertert22()
Dim x, y(), i&, j#, k, cl&, t#, s$
Const kf As Double = 0.001
On Error Resume Next: Err.Clear
x = Range("H2:J" & Cells(Rows.Count, 8).End(xlUp).Row).Value
ReDim y(1 To 4, 1 To 100): t = -1
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(x, 1)
x(i, 2) = x(i, 2) * kf: x(i, 3) = x(i, 3) * kf
If Not .exists(x(i, 1)) Then Set .Item(x(i, 1)) = New Collection
Do
.Item(x(i, 1)).Add x(i, 2), CStr(x(i, 2))
x(i, 2) = x(i, 2) + kf
Loop Until Round(x(i, 2), 3) > Round(x(i, 3), 3)
Next i
x = Range("B2:D" & Cells(Rows.Count, 2).End(xlUp).Row).Value
For i = 2 To UBound(x, 1)
x(i, 2) = x(i, 2) * kf: x(i, 3) = x(i, 3) * kf
If .exists(x(i, 1)) Then
Do
.Item(x(i, 1)).Remove CStr(x(i, 2))
x(i, 2) = x(i, 2) + kf
Loop Until Round(x(i, 2), 3) > Round(x(i, 3), 3)
End If
Next i
For Each k In .keys
For i = 1 To .Item(k).Count
If .Item(k)(i) = t + kf Then
y(3, cl) = .Item(k)(i) / kf
y(4, cl) = y(4, cl) + 1
Else
cl = cl + 1: If cl > UBound(y, 2) Then ReDim Preserve y(1 To 4, 1 To UBound(y, 2) * 2)
y(1, cl) = k
y(2, cl) = .Item(k)(i) / kf
y(3, cl) = .Item(k)(i) / kf
y(4, cl) = 1
End If
t = .Item(k)(i)
Next i
Next k
End With
With Range("N3:Q3")
.CurrentRegion.Offset(2).ClearContents
.Resize(cl).Value = Application.Transpose(y)
End With
End Sub
If you have Excel x64 bit, try to use a data type
Bookmarks