cwb1021
04-03-2017, 05:48 AM
Experts,
This is an extension of a previous post found here. Thanks to all who replied there.
http://www.vbaexpress.com/forum/showthread.php?59027-Need-help-passing-variable-values-to-For-Loop
I have a procedure that uses values from multiple columns in a calculation which populates a new column. All of this is working well, but now after the calculation is performed, I'm trying to copy the entire contents of the worksheet to a new worksheet and delete certain rows after the data has been pasted. The value "ScanRad" is input through a user form, and if the previously calculated value is less than "ScanRad", that entire row is deleted (at least that's my attempt). What I have here works to an extent, but only deleted some of the rows while leaving others that should have been deleted.
Here is the code so far:
Option Explicit
Private Sub CalcDistButton1_Click()
Dim ScanRad As Single
Dim SubLat As Double, SubLon As Double
Dim FilterCell As Range, DataRange As Range, RadCell As Range, FilteredRange As Range
Dim x As Variant, y As Variant, z As Variant
Dim wsFS As Worksheet
Set wsFS = Worksheets("FilteredSet")
'Pull scan radius value from input box
With Worksheets("sheet1")
Set DataRange = Range(.Cells(2, 9), .Cells(Rows.Count, 9).End(xlUp)).SpecialCells(xlCellTypeVisible)
End With
ScanRad = UserForm1.TextBox3.Text
SubLat = UserForm1.TextBox1.Text
SubLon = UserForm1.TextBox2.Text
'Calculate offset distance for unhidden rows
For Each FilterCell In DataRange
x = FilterCell.Offset(, 1)
y = FilterCell.Offset(, 2)
z = FilterCell.Offset(, 4)
With Application
FilterCell.Offset(, 5) = Application.Acos(Cos(Application.Radians(90 - SubLat)) * Cos(Application.Radians(90 - x)) + Sin(Application.Radians(90 - SubLat)) * _
Sin(Application.Radians(90 - x)) * Cos(Application.Radians(SubLon - y))) * ((z) / 5280)
End With
Next FilterCell
'Copy/Paste values from Sheet 1 to worksheet "FilteredSet"
Worksheets("sheet1").UsedRange.Copy
wsFS.Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Set FilteredRange = Intersect(wsFS.Columns(14), wsFS.UsedRange)
For Each RadCell In FilteredRange
If IsNumeric(RadCell.Value) And RadCell.Value > ScanRad Then
RadCell.EntireRow.Delete
End If
Next RadCell
End Sub
As you can see from the result, if I input a value of 10 for "ScanRad", on the new worksheets "FilteredSet", 3 rows with a value greater than 10 have been deleted, but 2 still remain.
Also, I've used IsNumeric so that the headers in the "FilteredSet" worksheet are not deleted. This works, but there may be a better way to do this?
And yes, I do have a reason for copying the data to a new worksheet before deleting any rows. I have another piece of code that will first filter the data on sheet 1 before pasting to the new worksheet and I will need to leave this dataset in tact. I just have not merged these parts together yet.
I've also attached the workbook.
Any help is greatly appreciated!
Thanks,
Chris
This is an extension of a previous post found here. Thanks to all who replied there.
http://www.vbaexpress.com/forum/showthread.php?59027-Need-help-passing-variable-values-to-For-Loop
I have a procedure that uses values from multiple columns in a calculation which populates a new column. All of this is working well, but now after the calculation is performed, I'm trying to copy the entire contents of the worksheet to a new worksheet and delete certain rows after the data has been pasted. The value "ScanRad" is input through a user form, and if the previously calculated value is less than "ScanRad", that entire row is deleted (at least that's my attempt). What I have here works to an extent, but only deleted some of the rows while leaving others that should have been deleted.
Here is the code so far:
Option Explicit
Private Sub CalcDistButton1_Click()
Dim ScanRad As Single
Dim SubLat As Double, SubLon As Double
Dim FilterCell As Range, DataRange As Range, RadCell As Range, FilteredRange As Range
Dim x As Variant, y As Variant, z As Variant
Dim wsFS As Worksheet
Set wsFS = Worksheets("FilteredSet")
'Pull scan radius value from input box
With Worksheets("sheet1")
Set DataRange = Range(.Cells(2, 9), .Cells(Rows.Count, 9).End(xlUp)).SpecialCells(xlCellTypeVisible)
End With
ScanRad = UserForm1.TextBox3.Text
SubLat = UserForm1.TextBox1.Text
SubLon = UserForm1.TextBox2.Text
'Calculate offset distance for unhidden rows
For Each FilterCell In DataRange
x = FilterCell.Offset(, 1)
y = FilterCell.Offset(, 2)
z = FilterCell.Offset(, 4)
With Application
FilterCell.Offset(, 5) = Application.Acos(Cos(Application.Radians(90 - SubLat)) * Cos(Application.Radians(90 - x)) + Sin(Application.Radians(90 - SubLat)) * _
Sin(Application.Radians(90 - x)) * Cos(Application.Radians(SubLon - y))) * ((z) / 5280)
End With
Next FilterCell
'Copy/Paste values from Sheet 1 to worksheet "FilteredSet"
Worksheets("sheet1").UsedRange.Copy
wsFS.Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Set FilteredRange = Intersect(wsFS.Columns(14), wsFS.UsedRange)
For Each RadCell In FilteredRange
If IsNumeric(RadCell.Value) And RadCell.Value > ScanRad Then
RadCell.EntireRow.Delete
End If
Next RadCell
End Sub
As you can see from the result, if I input a value of 10 for "ScanRad", on the new worksheets "FilteredSet", 3 rows with a value greater than 10 have been deleted, but 2 still remain.
Also, I've used IsNumeric so that the headers in the "FilteredSet" worksheet are not deleted. This works, but there may be a better way to do this?
And yes, I do have a reason for copying the data to a new worksheet before deleting any rows. I have another piece of code that will first filter the data on sheet 1 before pasting to the new worksheet and I will need to leave this dataset in tact. I just have not merged these parts together yet.
I've also attached the workbook.
Any help is greatly appreciated!
Thanks,
Chris