Insert blank rows based on column condition-CodePudding

I have to have atlest 4 rows for each manager (mgr col) and so that HR can assign task to each of them. HR will add values in new col, they can assign task up to 4 based. I am thinking to create a macro that can check minimum 4 lines for each manager if less than 4 add it and if more then no need to add.

For example:

Dep Mgr     Task
1   jerry   cheese
1   jerry   bread
2   tom     milk

Expected output:

Dep Mgr     Task     HRtask
1   jerry   cheese   ---
1   jerry   bread    ---
1   jerry    ---     ---        
1   jerry    ---     ---        
2   tom     milk     ---
2   tom      ---     ---
2   tom      ---     ---    
2   tom      ---     ---

--- is blank here.

what I found on internet

Sub Insert4RowsWithCondition()
'    here starting with A3 cell but need to set on unique value in that mgr col automatically
Range("A3").Select
Do Until ActiveCell.Value =""
Selection.EntireRow.Insert
Selection.EntireRow.Insert
ActiveCell.Offset(3,0).Select
Loop

error It is adding 2 new blank rows after each line which is not useful in my case.

CodePudding user response：

Try this... A bit lengthy though... I added the rows depending on Dep count instead of Mgr name, as there can be more than one mgr with same name... So Assuming Dep is some sort of Mgr's ID...

Sub Macro1()

' Get count of Dep
Columns("A:B").Select
Selection.Copy
Range("F1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Range("$F:$G").RemoveDuplicates Columns:=Array(1, 2), Header _
    :=xlYes
Range("H2").Select
ActiveCell.FormulaR1C1 = "=COUNTIFS(C1,RC[-2])"
Range("H2").Select
Selection.Copy
lRow = Cells(Rows.Count, 6).End(xlUp).Row
Range("H2:H" & lRow).Select
ActiveSheet.Paste
Application.CutCopyMode = False

' Number of rows to add
lRow = Cells(Rows.Count, 6).End(xlUp).Row
For i = 2 To lRow
    num = Cells(i, 8).Value
    If num < 4 Then
        Range("F" & i & ":" & "G" & i).Copy
        Range("A1").Select
        Selection.End(xlDown).Select
        For j = 1 To 4 - num
            ActiveCell.Offset(1, 0).Select
            ActiveSheet.Paste
        Next
    End If
Next

' Sorting Data
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range("A:A") _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
    .SetRange Range("A:D")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

Columns("F:H").ClearContents
Range("A1").Select

End Sub

Hope this Helps...