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

[malleshg24]

Hi Team,


Need your 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

[Bob Phillips]

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

[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 LongDim i As LongDim myrange As Range
    Application.ScreenUpdating = FalseWith 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 iEnd With    Application.ScreenUpdating = False
End Sub


Public Sub Situation_2()Dim lastrow As LongDim i As LongDim myrange As Range
    Application.ScreenUpdating = FalseWith 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 iEnd With    Application.ScreenUpdating = False
End Sub

[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

[Bob Phillips]

Straight off the top, untested

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

[malleshg24]

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