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

[rlv]

Private Sub OKButton_Click()
Me.Tag = "OK"
Me.Hide
End Sub


Sub GetDataFromForm()
Dim SelectedCounty As String

UserForm1.Show
If UserForm1.Tag = "OK" Then
SelectedCounty = UserForm1.ListBox1.List(UserForm1.ListBox1.ListIndex)
MsgBox "You have selected " & SelectedCounty & " county.", vbOKOnly, "Data From Form Listbox"
Else
MsgBox "Selection Cancelled", vbOKOnly , "Data From Form Listbox"
End If
End Sub

[cwb1021]

rlv,

Thanks for the response, but I was not wanting to use a userform. I had meant to delete it before posting. Instead, I was needing to pass selected values from the drop boxes as mentioned in the original post.

Thanks,

Chris

[mdmackillop]

If you need multiple selections, I'd suggest you add ListBoxes to your worksheet. Validation drop-downs won't allow multiples.

[cwb1021]

mdmackillop,

Thanks for your suggestion. I am able to make multiple selections by using the following code in the ScanRadius worksheet:

Private Sub Worksheet_Change(ByVal Target As Range)
'Code by Sumit Bansal from https://trumpexcel.com
' To Select Multiple Items from a Drop Down List in Excel
Dim Oldvalue As String
Dim Newvalue As String
Application.EnableEvents = True
On Error GoTo Exitsub
If Target.Address = "$D$2" Or Target.Address = "$C$2" Or Target.Address = "$G$2" Or Target.Address = "$H$2" Then
If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
GoTo Exitsub
Else: If Target.Value = "" Then GoTo Exitsub Else
Application.EnableEvents = False
Newvalue = Target.Value
Application.Undo
Oldvalue = Target.Value
If Oldvalue = "" Then
Target.Value = Newvalue
Else
If InStr(1, Oldvalue, Newvalue) = 0 Then
Target.Value = Oldvalue & ", " & Newvalue
Else:
Target.Value = Oldvalue
End If
End If
End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub


However, I have not gotten far enough to see how these might be passed to the procedure with multiple selections. So, as you say, this step may be made easier using list boxes?

If this is the case, I will need to create a user form and allow for the selections to be made there. This should not be a problem, and is actually how I had started. I then though it might be simpler to just use drop boxes and data validation.

But, I will try it both way.

Thanks again for your suggestion.

Chris