VBA - Seperating Column data based on Criteria.....

[malleshg24]

Hi xld/Team


Thanks for your help on this, I am getting my required output with below Code,
How to Shorten below Code by covering both the situation in Single Loop. Thanks Again

Option Explicit

Public Sub Situation_1()
    Dim lastrow As Long
    Dim i As Long
    Dim myrange As Range
    Application.ScreenUpdating = False
    With ActiveSheet
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = 3 To lastrow
             If .Cells(i, "B").Value = 50000 Then
                 Set myrange = Cells(i, "B")
                 With myrange
                    .EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    .EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    With .Offset(-2, -1).Resize(1, 2).Borders(xlEdgeBottom)                        '
                       .LineStyle = xlContinuous
                       .Weight = xlMedium
                    End With
                End With
                Exit Sub
            End If     
        Next i
    End With
    Application.ScreenUpdating = False
End Sub


Public Sub Situation_2()
    Dim lastrow As Long
    Dim i As Long
    Dim myrange As Range
    Application.ScreenUpdating = False
    With ActiveSheet
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = lastrow To 3 Step -1
             If .Cells(i, "B").Value = "" And .Cells(i - 1, "B").Value <> "" And .Cells(i - 1, "a").Value <> "" Then
                 Set myrange = Cells(i, "B")
                 With myrange
                    .EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    .EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    With .Offset(-2, -1).Resize(1, 2).Borders(xlEdgeBottom)                        '
                        .LineStyle = xlContinuous
                        .Weight = xlMedium
                    End With
                 End With
                 Exit For
             End If
         Next i
    End With
    Application.ScreenUpdating = False
End Sub