Solved: Reduce Numbers Down To A Specific Value

[PAB]

Good evening,

I have two figures in a sheet named “Deletion”, the first figure is in cell “D3” and the second figure is in cell “D4”.
I have a list of numbers in a sheet called “Results” going from cells “E8:J whatever”. The list will get longer over time.
I think I can probably achieve this with ...


Set rng1 = .Range(.Range("J8"), .Cells(Rows.Count, 5).End(xlUp))
I want to start with an array of numbers from 1 to the value in cell “D4” and delete out of the array whatever number is at the bottom of column “J”, then “I”, then “H” then “G” then “F” then “E”, then move up one row and go back to column “J”, then “I”, then “H” then “G” then “F” then “E” and move up one row and so on. This will reduce the numbers in the array down until I reach the number in “D3”.
I would like the "x" numbers left in the array to be output in the sheet named "Deletion" starting in cell "B9" and contiinuing down.

Thanks in advance.
PAB

[mdmackillop]

Welcome to VBAX,
If you could post a sample workbook showing Before and After, I'm sure we can help.

Use Manage Attachments in the Go Advanced reply section

[PAB]

Hi MD,

Thanks for the welcome.
I will attemp to attach the file by the way you suggested.

Thanks in advance.
PAB

[mdmackillop]

Option Explicit

Sub Deletions()

Dim rngA As Range
Dim rngB As Range
Dim Draw As Range
Dim Reduc As Range
Dim c As Range
Dim wsD As Worksheet
Dim wsR As Worksheet
Dim Strt As Range
Dim Rw As Long, Col As Long
Dim x As Long

Application.ScreenUpdating = False

Set wsD = Sheets("Deletion")
Set wsR = Sheets("Results")



With wsD
Set Draw = .Cells(4, 4)
Set Reduc = .Cells(3, 4)
Set rngA = .Cells(9, 2).Resize(Draw)
Set rngB = rngA.Offset(, 1)

rngB.ClearContents
rngA(1).Copy rngA
rngB(1).Copy rngB
rngA.Formula = "=row()-8"
rngA.Value = rngA.Value

End With


Set Strt = wsR.Cells(Rows.Count, "J").End(xlUp)
On Error Resume Next
For Rw = 0 To Strt.Row
For Col = 0 To 5
x = Strt.Offset(-Rw, -Col)
Debug.Print x
Set c = rngA.Find(x, lookat:=xlWhole)
If Not c Is Nothing Then c.Resize(, 2).Delete xlUp
If wsD.Cells(Rows.Count, 2).End(xlUp).Row = Reduc + 8 Then GoTo Result
Next Col
Next Rw
On Error GoTo 0

Result:
wsD.Cells(1, 1).Select
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

[PAB]

Hi MD,

That is excellent.
One other request please, how would I adapt the code to do exactly the same as it does but to also include the Bonus ball in column "K" and for the results to go from cell "C9" and continuing down next to the excluding bonus results. This way I will have both sets of results.

Thanks in advance for your time on this.
PAB

[mdmackillop]

You mean exclude the number starting at the bottom of K, or some other logic.

[PAB]

Hi MD,

Yes, that is correct.
That way I will have both sets of results, the first excluding the Bonus going from cell "B9" and continuing down and the second including the Bonus starting in cell "C9" and continuing down.

Thanks in advance.
PAB

[mdmackillop]

Option Explicit

Sub Deletions()

Dim rngA As Range
Dim rngB As Range
Dim Draw As Range
Dim Reduc As Range
Dim c As Range
Dim wsD As Worksheet
Dim wsR As Worksheet
Dim Strt As Range
Dim Rw As Long, Col As Long
Dim x As Long

Application.ScreenUpdating = False

Set wsD = Sheets("Deletion")
Set wsR = Sheets("Results")



With wsD
Set Draw = .Cells(4, 4)
Set Reduc = .Cells(3, 4)
Set rngA = .Cells(9, 2).Resize(Draw)
Set rngB = rngA.Offset(, 1)

rngB.ClearContents
rngA(1).Copy rngA
rngB(1).Copy rngB
rngA.Resize(, 2).Formula = "=row()-8"
rngA.Resize(, 2).Value = rngA.Resize(, 2).Value

End With


Set Strt = wsR.Cells(Rows.Count, "J").End(xlUp)
On Error Resume Next
For Rw = 0 To Strt.Row
For Col = 0 To 5
x = Strt.Offset(-Rw, -Col)
Debug.Print x
Set c = rngA.Find(x, lookat:=xlWhole)
If Not c Is Nothing Then c.Delete xlUp
If wsD.Cells(Rows.Count, 2).End(xlUp).Row = Reduc + 8 Then GoTo BonusBall
Next Col
Next Rw

BonusBall:
Set Strt = wsR.Cells(Rows.Count, "K").End(xlUp)
On Error Resume Next
For Rw = 0 To Strt.Row
x = Strt.Offset(-Rw)
Debug.Print x
Set c = rngB.Find(x, lookat:=xlWhole)
If Not c Is Nothing Then c.Delete xlUp
If wsD.Cells(Rows.Count, 3).End(xlUp).Row = Reduc + 8 Then GoTo Result
Next Rw

Result:
wsD.Cells(1, 1).Select
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

[PAB]

Hi MD,

Thank you so much.
I just had to change one line and add two extra lines in the including Bonus bit and now it works perfectly.


Option Explicit

Sub Deletions()

Dim rngA As Range
Dim rngB As Range
Dim Draw As Range
Dim Reduc As Range
Dim c As Range
Dim wsD As Worksheet
Dim wsR As Worksheet
Dim Strt As Range
Dim Rw As Long, Col As Long
Dim x As Long

Application.ScreenUpdating = False

Set wsD = Sheets("Deletion")
Set wsR = Sheets("Results")

With wsD
Set Draw = .Cells(4, 4)
Set Reduc = .Cells(3, 4)
Set rngA = .Cells(9, 2).Resize(Draw)
Set rngB = rngA.Offset(, 1)

rngB.ClearContents
rngA(1).Copy rngA
rngB(1).Copy rngB
rngA.Resize(, 2).Formula = "=row()-8"
rngA.Resize(, 2).Value = rngA.Resize(, 2).Value

End With

Set Strt = wsR.Cells(Rows.Count, "J").End(xlUp)
On Error Resume Next
For Rw = 0 To Strt.Row
For Col = 0 To 5
x = Strt.Offset(-Rw, -Col)
Debug.Print x
Set c = rngA.Find(x, lookat:=xlWhole)
If Not c Is Nothing Then c.Delete xlUp
If wsD.Cells(Rows.Count, 2).End(xlUp).Row = Reduc + 8 Then GoTo BonusBall
Next Col
Next Rw

BonusBall:
Set Strt = wsR.Cells(Rows.Count, "K").End(xlUp)
On Error Resume Next
For Rw = 0 To Strt.Row
For Col = 0 To 6

x = Strt.Offset(-Rw, -Col)
Debug.Print x
Set c = rngB.Find(x, lookat:=xlWhole)
If Not c Is Nothing Then c.Delete xlUp
If wsD.Cells(Rows.Count, 3).End(xlUp).Row = Reduc + 8 Then GoTo Result
Next Col
Next Rw

Result:
wsD.Cells(1, 1).Select
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

Thanks again.
PAB

[mdmackillop]

I see now what you were after. Happy it works!

[PAB]

Thanks for your help MD.

All the best,
PAB