how to create a dropdown list in multiple excel sheets from data of one sheet-CodePudding

This is a tough task that I must complete for a collegue project. I'm not an expert doing vba macros but trying my best so far so lets start the explanation:

First, I have multiples sheets (around 300) that are called by Matrix and followed by a number from 1 to 330, e.g: Matrix1,Matrix2, etc., each of these sheets contains multiple product attributes that are positioned in row 1 as can be seen in the next screenshot:

what I need to do is that every time a product attribute that contains the phrase: "Select from dropdown list" in row number 2, automatically generate a dropdown list in the same column, from row 3 to row 100. The values that should be in the generated dropdown list come from the "Dropdown" sheet as shown below:

As can be seen, a product attribute contains a long list of values and would need those values to be displayed in the dropdown list according to the attribute that corresponds to it. This should happen for each of the matrix sheets that the excel has.

this is the code that previously helped me for a past task, but this one requires more extensive coding:

Option Explicit

Sub MultiDataValidation()
    
    Const sName As String = "Sheet1"
    Const scCol As String = "A"
    Const svCol As String = "B"
    Const sfRow As Long = 6
    
    Const dName As String = "Sheet1"
    Const dcAddress As String = "G2:I2"
    Const dvRow As Long = 3
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, svCol).End(xlUp).Row
    If slRow < sfRow Then Exit Sub ' no data
    Dim srCount As Long: srCount = slRow - sfRow   1
    Dim scrg As Range: Set scrg = sws.Cells(sfRow, scCol).Resize(srCount)
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dcrg As Range: Set dcrg = dws.Range(dcAddress)
    
    Dim srg As Range
    Dim sCell As Range
    Dim srIndex As Variant
    Dim dCell As Range
    
    For Each dCell In dcrg.Cells
        srIndex = Application.Match(dCell.Value, scrg, 0)
        If IsNumeric(srIndex) Then
            Set sCell = scrg.Cells(srIndex)
            If sCell.MergeCells Then
                Set srg = sCell.MergeArea
            Else
                Set srg = sCell
            End If
            With dCell.EntireColumn.Rows(dvRow).Validation
                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
                    Formula1:="=" & srg.EntireRow.Columns(svCol).Address
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With
        End If
    Next dCell
    
End Sub

CodePudding user response：

Distribute Dropdowns

Option Explicit

Sub DistributeDropdowns()
    Const ProcName As String = "DistributeDropdowns"
    On Error GoTo ClearError

    Const sName As String = "Dropdown"
    Const saCol As Long = 1
    Const svCol As Long = 2
    
    Const dNameLeft As String = "Matrix"
    Const ddIdentifier As String = "Select from the dropdown list."
    Const dvRows As String = "3:100"

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion.Columns(saCol)

    Dim nCount As Long: nCount = srg.Rows.Count
    Dim nData As Variant: nData = srg.Value
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim n As Long
    Dim nString As String
    
    For n = 2 To nCount
        nString = nData(n, 1)
        If dict.Exists(nString) Then
            Set dict(nString) = Union(dict(nString), sws.Cells(n, svCol))
        Else
            Set dict(nString) = sws.Cells(n, svCol)
        End If
    Next n
        
    Dim dLen As Long: dLen = Len(dNameLeft)

    Application.ScreenUpdating = False

    Dim dws As Worksheet
    Dim drg As Range
    
    For Each dws In wb.Worksheets
        If Left(dws.Name, dLen) = dNameLeft Then
            With dws.Range("A1").CurrentRegion.Resize(2)
                nCount = .Columns.Count
                nData = .Value
                Set drg = .EntireColumn.Rows(dvRows)
            End With
            For n = 2 To nCount
                If nData(2, n) = ddIdentifier Then
                    If dict.Exists(nData(1, n)) Then
                        With drg.Columns(n).Validation
                            .Delete
                            .Add xlValidateList, xlValidAlertStop, xlEqual, _
                                "='" & sName & "'!" & dict(nData(1, n)).Address
                            .IgnoreBlank = True
                            .InCellDropdown = True
                            .InputTitle = ""
                            .ErrorTitle = ""
                            .InputMessage = ""
                            .ErrorMessage = ""
                            .ShowInput = True
                            .ShowError = True
                        End With
                    End If
                End If
            Next n
        End If
    Next dws
    
    'wb.Save
    
    Application.ScreenUpdating = True
    MsgBox "Dropdowns distributed.", vbInformation

ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Sub