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

Hi Team,


Need your help, :help


From Column (Score ) Whenever you find First 50000 from top to Bottom, Seperate the row
by adding two blank row on above that row and give border to line on below row.


Next Challenge,
if I have players name in Column A, but Runs not available in Column B , Seprate those players
by adding two blank row above of that row. and border one line
Needs to cover both the the situation, I have added input files , expected result in output file,

Thanks in advance for help.


Regards,
mg

Code:

---

Option Explicit

Public Sub AddBlanks()
    Dim lastrow As Long
    Dim i As Long
    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 = vbNullString Or .Cells(i, "B").Value = 50000 Then           
                .Rows(i).Resize(2).Insert
            End If
        Next i
    End With   
    Application.ScreenUpdating = True
End Sub

---

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

Code:

---

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

---

Straight off the top, untested

Code:

---

Option Explicit

Public Sub Situation()
    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 Or _
                (.Cells(i, "B").Value = vbNullString And .Cells(i - 1, "B").Value <> vbNullString And .Cells(i - 1, "A").Value <> vbNullString) 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

---

Hi xld,
Thanks again for your reply on this, I tested the code and tried with modifying it,
but not getting the desired output.


maximum there will be one or two borders, First on 50000 value on Column B. not every 50000 values.
next will be first blank cell at the bottom. I have attached output sheet for ref. Thanks


Regards
mg