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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.