Experts,
I have the following code below which compares the numbers in 1 column against a benchmark, and if the numbers are less than the benchmark pastes offset values in the same row to a new worksheet. Thanks to mdmackillop for help with the base code for this. I'm now trying to modify the code to accept multiple selections from drop boxes and use these values in conditional statements within the procedure.
First, here is the original code, which works:
Sub GetOffsets()
Dim cell As Range, OffsetRange As Range, OffsetPicks As Range, DupRng As Range
Dim ScanRadius As Single
Dim wsS As Worksheet
Dim wsO As Worksheet
Set wsS = Worksheets("Sample")
Set wsO = Worksheets("OffsetList")
Set OffsetPicks = Intersect(wsO.Columns(1), wsO.UsedRange)
OffsetPicks.ClearContents
'Limits data scanned to last row of used section - eliminates scanning of blank cells
Set OffsetRange = Intersect(wsS.Columns(7), wsS.UsedRange)
'Sets variable ScanRadius to value input on worksheet
ScanRadius = Worksheets("ScanRadius").Range("c3")
'Compares each offset distance to scan radius and returns well name value to OffsetList
For Each cell In OffsetRange
If cell.Value <= ScanRadius Then
cell.Offset(, -6).Copy
wsO.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
cell.Offset(, -5).Copy
wsO.Cells(Rows.Count, 2).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
cell.Offset(, 4).Copy
wsO.Cells(Rows.Count, 3).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
End If
Next cell
'Removes duplicate well names from OffsetList worksheet
With wsO
Set DupRng = Range("a1").End(xlDown)
DupRng.RemoveDuplicates Columns:=Array(1), Header:=xlYes
End With
'Adds Column Header to C1 in worksheet OffsetList - Need to modify loop to not delete header
Workbooks("MacroTest.xlsm").Worksheets("OffsetList").Range("A1").Value = "Name"
wsO.Range("a100:a1000").ClearContents
End Sub
There are a couple of issues with this code:
1) When looping through the column 7 in wsO, it seems to be looping through all the rows in the worksheet, making it run very slowly (~2 minutes). I thought that this was fixed with the "intersect" line in bold face above, but it does not seem to work.
2) After the procedure is complete, it leaves values in columns B and C for one extra row in worksheet "Offset List".
Although these are not my primary question, any help is appreciated.
So, Im trying to modify the above code to do 3 things:
1. pass the values from 4 drop boxes in worksheet "ScanRadius", c2, d2, g2 & h2
2. be able to handle multiple selections from the drop boxes
3. if no value is selected in a drop box, use no values from that box, and generate a message box upon initiating asking for a selection to be made.
For example, in the attached workbook, if the following selections are made: County = BLN, Form = ML1, ML2, Diam = 875, Sect = CVE
I would like for the values Selected for County to compare to column 2 in "Sample", the values selected for Form to compare to column 11 in "Sample" and so on. And if these values match, proceed to return the designated offset values to "Offset List" as the first bit of code did.
So I've started with the code modification, but am pretty lost...
Sub GetOffsets()
Dim cell As Range, OffsetRange As Range, OffsetPicks As Range, DupRng As Range
Dim ScanRadius As Single
Dim wsS As Worksheet
Dim wsO As Worksheet
Dim wsSR As Worksheet
Dim CountyPick As String, FormPick As String, HSPick As String, SectPick As String
Dim CountyRange As Range, FormRange As Range, HSRange As Range, SectRange As Range
Set wsS = Worksheets("Sample")
Set wsO = Worksheets("OffsetList")
Set wsSR = Worksheets("ScanRadius")
Set OffsetPicks = Intersect(wsO.Columns(1), wsO.UsedRange)
OffsetPicks.ClearContents
Set CountyRange = Intersect(wsS.Columns(2), wsS.UsedRange)
Set FormRange = Intersect(wsS.Columns(11), wsS.UsedRange)
Set HSRange = Intersect(wsS.Columns(10), wsS.UsedRange)
Set SectRange = Intersect(wsS.Columns(18), wsS.UsedRange)
CountyPick = wsSR.Range("C2")
FormPick = wsSR.Range("D2")
HSPick = wsSR.Range("G2")
SectPick = wsSR.Range("H2")
'Limits data scanned to last row of used section - eliminates scanning of blank cells
Set OffsetRange = Intersect(wsS.Columns(7), wsS.UsedRange)
'Sets variable ScanRadius to value input on worksheet
ScanRadius = Worksheets("ScanRadius").Range("c3")
'Compares each offset distance to scan radius and returns well name value to OffsetList
For Each cell In OffsetRange
If cell.Value <= ScanRadius Then
If CountyPick = wsS.Range("CountyRange") Then
If FormPick = wsS.Range("FormRange") Then etc , etc
cell.Offset(, -6).Copy
wsO.Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
cell.Offset(, -5).Copy
wsO.Cells(Rows.Count, 2).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
cell.Offset(, 4).Copy
wsO.Cells(Rows.Count, 3).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
End If
Next cell
'Removes duplicate well names from OffsetList worksheet
With wsO
Set DupRng = Range("a1").End(xlDown)
DupRng.RemoveDuplicates Columns:=Array(1), Header:=xlYes
End With
'Adds Column Header to C1 in worksheet OffsetList - Need to modify loop to not delete header
Workbooks("ForumPost.xlsm").Worksheets("OffsetList").Range("A1").Value = "Name"
wsO.Range("a100:a1000").ClearContents
'wsO.Range("a1").Activate
End Sub
Apologies for such a long post. Any help is greatly appreciated!
Thanks,
Chris