Consulting

Results 1 to 5 of 5

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

  1. #1
    VBAX Regular
    Joined
    Mar 2017
    Posts
    32
    Location

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

    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
    Attached Files Attached Files
    Last edited by SamT; 03-20-2017 at 07:26 PM.

  2. #2
    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

  3. #3
    VBAX Regular
    Joined
    Mar 2017
    Posts
    32
    Location
    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

  4. #4
    Administrator
    VP-Knowledge Base
    VBAX Grand Master mdmackillop's Avatar
    Joined
    May 2004
    Location
    Scotland
    Posts
    14,488
    Location
    If you need multiple selections, I'd suggest you add ListBoxes to your worksheet. Validation drop-downs won't allow multiples.
    MVP (Excel 2008-2010)

    Post a workbook with sample data and layout if you want a quicker solution.


    To help indent your macros try Smart Indent

    Please remember to mark threads 'Solved'

  5. #5
    VBAX Regular
    Joined
    Mar 2017
    Posts
    32
    Location
    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •