Consulting

Results 1 to 5 of 5

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

  1. #1

    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 
    
    
    Formatting tags added by mark007
    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 
    
    
    Formatting tags added by mark007
    Apologies for such a long post. Any help is greatly appreciated!

    Thanks,

    Chris
    Attached Files Attached Files
      To view attachments your post count must be 0 or greater. Your post count is 0 momentarily.
    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 
    
    
    Formatting tags added by mark007

  3. #3
    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
    13,797
    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
    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
  •