VBA Insert Row after cell value changes.

[DeanRobinson]

Hi all i want to extend the below code to insert blank rows after the value of a cell changes so once it runs the below code which pulls data from another file and then sorts the data, i now want it to go one step further and everytime the value in Column G changes it will add a blank row,

The sheet assigns the technicain to his team manager and then sorts first by the team managers name, second by the tech id and third by the appointment time slot. Just to make to easier to read what id like is once the tech id changes it would insert an entire blank row. i hope this makes sense.

ISub TeamManager()
With Application: .ScreenUpdating = False: [b:b].EntireColumn.Insert: [b1] = "Team Manager"
With Range([b2], Cells(ActiveSheet.UsedRange.Rows.Count, 2))
.FormulaR1C1 = "=IF(ISERROR(VLOOKUP(RC[5],'C:\Users\DeanRobinson\Documents\[TECHTM.xls]Sheet1'!C1:C2,2,0)),"""",VLOOKUP(RC[5],'C:\Users\DeanRobinson\Documents\[TECHTM.xls]Sheet1'!C1:C2,2,0))"
.Copy: .PasteSpecial Paste:=xlPasteValues
End With: Application.CutCopyMode = False: .ScreenUpdating = True: End With:
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B:B") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("G:G") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("J:J") _
, SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
"FIRST VISIT,8am-1pm,10am-2pm,12-6pm,1pm-6pm", DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A:CI")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
End Sub

 

[jbeaucaire]

Something like this:

Option Explicit

Sub TeamManager()
Dim LR As Long, Rw As Long
Application.ScreenUpdating = False

With ActiveSheet
    LR = .Range("A" & .Rows.Count).End(xlUp).Row
    .[B:B].Insert
    .[B1] = "Team Manager"
    
    With .Range("B2:B" & LR)
        .FormulaR1C1 = "=IF(ISERROR(VLOOKUP(RC[5],'C:\Users\DeanRobinson\Documents\[TECHTM.xls]Sheet1'!C1:C2,2,0)),"""",VLOOKUP(RC[5],'C:\Users\DeanRobinson\Documents\[TECHTM.xls]Sheet1'!C1:C2,2,0))"
        .Value = .Value
    End With
    
    .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=Range("B:B"), SortOn:=xlSortOnValues, _
        Order:=xlAscending, DataOption:=xlSortNormal
    .Sort.SortFields.Add Key:=Range("G:G"), SortOn:=xlSortOnValues, _
        Order:=xlAscending, DataOption:=xlSortNormal
    .Sort.SortFields.Add Key:=Range("J:J"), SortOn:=xlSortOnValues, _
        Order:=xlAscending, _
        CustomOrder:="FIRST VISIT,8am-1pm,10am-2pm,12-6pm,1pm-6pm", _
        DataOption:=xlSortNormal
    
    With .Sort
        .SetRange Range("A:CI")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With

    For Rw = LR To 3 Step -1
        If .Range("G" & Rw) <> .Range("G" & Rw - 1) Then
            .Rows(Rw).Insert xlShiftDown
            Rw = Rw - 1
        End If
    Next Rw
End With

Application.ScreenUpdating = True
End Sub

 

[DeanRobinson]

That works perfectly, thank you.