這是一項艱巨的任務，我必須為一個同事專案完成。我不是做 vba 宏的專家，但到目前為止我已經盡力了，所以讓我們開始解釋：
首先，我有多個作業表（大約 300 個）由 Matrix 呼叫，后跟一個從 1 到 330 的數字，例如：Matrix1、Matrix2 等，這些作業表中的每一個都包含多個產品屬性，這些屬性盡可能位于第 1 行中在下一個螢屏截圖中可以看到：
我需要做的是，每次在第 2 行中包含短語：“從下拉串列中選擇”的產品屬性時，都會在同一列中自動生成一個下拉串列，從第 3 行到第 100 行。應該是的值在生成的下拉串列中來自“下拉”表，如下所示：
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
uj5u.com熱心網友回復：
分發下拉選單
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
轉載請註明出處，本文鏈接：https://www.uj5u.com/yidong/439944.html
上一篇：在VBA中定義引數的最佳布局