CODEWITHSUNDEEP
vbaexceldrop-down-menu
Markus Sacramento
Markus Sacramento

Reputation: 364

Excel create dropdown if same value occures in multiple rows

I have a code which loops through a range in first sheet and matches with value on second sheet. If a match as far as I see is verifies if A cell contains only numbers and if it is true it copies from sheet 2 D col and places it one cell at the right. What I would like to do is that if the value in A coll occures more than once och would like a drop down to be created so that I can choose between the values retrieved from sheet 2 D coll.

For Each c In w1.Range("D2", w1.Range("D" & Rows.Count).End(xlUp))
FR = Application.Match(c, w2.Columns("A"), 0)
If IsNumeric(FR) Then c.Offset(, 2).Value = w2.Range("D" & FR).Value
Next c

  Dim myList As String, r As Range

Below is a dropdown I use for other things that is created when value exists in A coll.

myList = "Yes,No"

If w1.Range("A" & Rows.Count).End(xlUp).Address <> "$A$1" Then
    For Each r In w1.Range("A2", w1.Range("A" & Rows.Count).End(xlUp))
        If r.Value <> vbNullString Then
            With r.Offset(, 2).Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=myList
            End With
            If r.Offset(, 2).Value = "" Then r.Offset(, 2).Value = "No"
            If r.Offset(, 2).Value = "" Then Split myList, ","
            End If
    Next r
End If

This is sheet one enter image description here

This is sheet two ![enter image description here

Upvotes: 0

Views: 216

Answers (1)

DisplayName
DisplayName

Reputation: 13386

Being all "sheet two" column A same values adjacent, then I'd go as follows (explanation in comments):

Dim comments As String
With w2 'reference "sheet two"
    With .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)) 'reference its column A cells from row 1 (header) down to last not empty one
        For Each c In w1.Range("D2", w1.Range("D" & Rows.Count).End(xlUp)) 'loop through "sheet one" column D cells from row 2 down to last not empty one
            .AutoFilter Field:=1, Criteria1:=c.Value ' filter referenced cells on 1st column with current "sheet one" column D cell content
            Select Case Application.WorksheetFunction.Subtotal(103, .Columns(1)) 'check how many filtered cells
                Case 2 'if only one other than header (always selected)
                    c.Offset(, 2).Value = .Offset(1, 3).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) ' just copy the sheet two column A filtered cell corresponding comment in column F and paste to "sheet one" column F cell corrisponding to current column D cell row
                Case Is > 2 'if more than one other than header (always selected)
                    comments = Join(Application.Transpose(.Offset(1, 3).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Value), ",") 'gather all comments in a string
                    With c.Offset(, 2).Validation 'reference "sheet one" column F cell corresponding to column D current one
                        .Delete
                        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=comments 'add validation list to referenced range
                    End With
            End Select
        Next
    End With
    .AutoFilterMode = False
End With

Upvotes: 1

Related Questions