Нарастить базу данных

[edition]

Добрый день!
Нужна помощь!!!
Необходимо искуственно нарастить базу данных.

Имеем массив данных из 7500 записей!

Как только в колонке <adr2> встречается пустое поле необходимо вставить указанное в колонке <nr.> количество рядов и в них скопировать значение предыдущего ряда.
На примере:
1-ое пустое поле-алгоритм-вставляем 1 ряд и копируем значение <сссс>.
2-oe путое поле-вставляем 8 пустых рядов и значение <3333>, 3-е пустое поле в <adr2> - вставляем 3 пустых ряда и значение <4444>

ID nr. uniq1 uniq2 name date adr1 adr2
aaaa aaaa aaaa aaaa aaaa aaaa aaaa aaaa
ssss ssss ssss ssss ssss ssss ssss ssss
xxxx xxxx xxxx xxxx xxxx xxxx xxxx xxxx
cccc cccc cccc cccc cccc cccc cccc cccc
5 1
dddd dddd dddd dddd dddd dddd dddd dddd
eeee eeee eeee eeee eeee eeee eeee eeee
rrrr rrrr rrrr rrrr rrrr rrrr rrrr rrrr
3333 3333 3333 3333 3333 3333 3333 3333
12 8
4444 4444 4444 4444 4444 4444 4444 4444
4 3

Как автоматизировать процесс?

[EugeneS]

выложите файл с примером, количество данных можно уменьшить, конфиденциальные данные замените

[edition]

Фрагмент данных!

[doober]

Вставлять выше.ниже этого поля,убрать это поле

[doober]

 Sub Start()
 Dim n As Long, m As Long, L As Long
 Application.ScreenUpdating = False
With Sheets(1)
  dd = Split(.Range("H1:H65500").SpecialCells(xlCellTypeConstants).Address, ",", -1)
  ReDim adr(0 To UBound(dd))
  For n = 0 To UBound(dd)
     Dim KL
     KL = Split(dd(n), "$", -1)
     adr(n) = KL(UBound(KL))
  Next
 For n = UBound(adr) To 0 Step -1
    On Error Resume Next
     L = .Cells(adr(n) + 1, 2)
  For m = 1 To L
    .Rows(adr(n) + 1).Insert
    .Rows(adr(n)).Copy .Rows(adr(n) + 1)
  Next
 Next
 End With
 
  Application.ScreenUpdating = True
End Sub

[EugeneS]

см. вложение

[edition]

Огромное спасибо!!! Всё получилось!