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