```
Sub Satv()
Dim orig As Worksheet, aux As Worksheet, lr%, bsr As Range, i%
Set aux = Sheets("sheet1") ' auxiliary sheet
Set orig = Sheets("plan2") ' original sheet
orig.[d:d].ClearContents
orig.[d1] = "Result"
aux.Activate
Cells.ClearContents
orig.[a:a].Copy aux.[a1]
lr = Range("a" & Rows.Count).End(xlUp).Row
[b1] = "Len"
[b2].FormulaR1C1 = "=LEN(RC[-1])"
[b2].AutoFill Destination:=Range("B2:B" & lr), Type:=xlFillDefault
[c1] = [b1]
Range("b1:b" & lr).AdvancedFilter xlFilterCopy, [c1:c2], [d1], True
Set bsr = [e1]
For i = 2 To Range("d" & Rows.Count).End(xlUp).Row
bsr.Offset(1).Formula = "=b2=" & Cells(i, 4)
Range("a1:b" & lr).AdvancedFilter xlFilterCopy, bsr.Resize(2, 1), bsr.Offset(, 1), False
DM bsr.Offset(1, 2), bsr.Offset(1, 1), bsr.Offset(1, 3)
Range(Cells(2, bsr.Offset(, 3).Column), Cells(Range(Split(bsr.Offset(, 3).Address, "$")(1) _
& Rows.Count).End(xlUp).Row, bsr.Offset(, 3).Column)).Copy _
orig.Cells(orig.Range("d" & Rows.Count).End(xlUp).Row + 1, 4)
Set bsr = bsr.Offset(, 4)
Next
End Sub
Sub DM(totrange As Range, drng As Range, dest As Range)
Dim a, lr, i%, d As Object, mn%, mx%, pref$, it, j%
Set d = CreateObject("Scripting.Dictionary")
lr = Range(Split(drng.Address, "$")(1) & Rows.Count).End(xlUp).Row
ReDim a(2 To lr)
j = 0
Do
j = j + 1
Loop While Not IsNumeric(Mid(drng, j, 1)) And j < 20
j = j - 1
pref = Left(drng, j)
mn = 30000: mx = 0
For i = 2 To lr
a(i) = Right(Cells(i, drng.Column), Len(Cells(i, drng.Column)) - j)
If a(i) < mn Then mn = a(i)
If a(i) > mx Then mx = a(i)
Next
For i = mn To mx
it = pref & WorksheetFunction.Rept("0", totrange.Value - Len(pref & i)) & i
d.Add it, it
Next
For i = 2 To lr
If d.Exists(Cells(i, drng.Column).Value) Then d.Remove Cells(i, drng.Column).Value
Next
dest.Resize(d.Count).Value = WorksheetFunction.Transpose(d.Keys)
End Sub
```