PDA

View Full Version : VBA - Seperating Column data based on Criteria.....



malleshg24
07-06-2019, 01:16 AM
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

Bob Phillips
07-07-2019, 06:12 AM
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
07-07-2019, 09:31 AM
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
07-07-2019, 09:34 AM
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
07-11-2019, 11:45 AM
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
07-11-2019, 07:02 PM
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