Passing selections from a drop down box to loop in sub procedure

[cwb1021]

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