Find missing member from list and add a blank row there

[wapcoslucknow]

Hello,

I need a very special answer from you, since I am not fluent in VB, I am not able to sole it.

I have a group (slave group) in Excel like: -

HT line length	0.01
HT Poles	4
LT Line Length	0.56
LT Poles	10
DTR 25 KVA	2
BPL	118

And a master group like: -

HT line length

HT Poles

LT Line Length

LT Poles

DTR 10 KVA

DTR 16 KVA

DTR 25 KVA

DTR 63 KVA

BPL

Master group has 9 elements, whereas sub group can have any number of elements from these 9 items (maximum 9). Here, 6 members out of 9.
My requirement is arranging sub group like: -

HT line length	0.01
HT Poles	4
LT Line Length	0.56
LT Poles	10
DTR 10 KVA
DTR 16 KVA
DTR 25 KVA	2
DTR 63 KVA
BPL	118

Here, blank rows are inserted, as per master group i.e. master group has to be followed and blank row should be inserted at missing points.
Also there will be so many sub group in the same sheet (one after other downwards)
I hope you understand my question.

Thanks

 

[wapcoslucknow]

Change references, like sheet names, as required

Sub AAAAA_3_Sheet3()
Dim myAreas As Areas, myAreas_2 As Areas
Dim a, i As Long, ii As Long, j As Long
Dim lr As Long, lc As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = Cells.Find("*", , , , xlByColumns, xlPrevious).Column
Application.ScreenUpdating = False
a = Range("A1:A" & lr).Value
Set myAreas = ActiveSheet.Columns(4).SpecialCells(2).Areas
    For i = 1 To myAreas.Count
        Cells(Rows.Count, lc + 100).End(xlUp).Offset(2).Resize(lr).Value = a
    Next i
    Cells(1, lc + 100).Resize(2).Delete Shift:=xlUp
Set myAreas_2 = ActiveSheet.Columns(lc + 100).SpecialCells(2).Areas
    For ii = 1 To myAreas_2.Count
        With Range(myAreas_2(ii).Address)
            For j = 1 To lr
                On Error Resume Next
                    myAreas_2(ii).Cells(j).Offset(, 1).Resize(, 2).Value = Range(myAreas(ii).Address).Find(myAreas_2(ii).Cells(j)).Offset(, 1).Resize(, 2).Value
                On Error GoTo 0
            Next j
        End With
    Next ii
With Range(Cells(1, lc + 100), Cells(Cells(Rows.Count, lc + 100).End(xlUp).Row, lc + 100)).Resize(, 3)
    .Copy Cells(1, 4)
    .ClearContents
End With
Application.ScreenUpdating = True
End Sub

Thanks, now it is working perfectly

 

[jolivanes]

Thanks for letting us know.
In the future, don't quote whole Posts. All extra clutter we don't need.
Good luck