Question

我有一个包含两列的表格：

Employee    Company
970423-4829 Vete
970212-2398 AlfaLaval
970212-2398 DeLaval
970423-4829 Verktyg
970423-4829 Verktyg
960822-7587 Arla
970423-4829 test3
961225-7590 Test
970911-1287 Kamel
970911-1287 Kanel

我想创建一个包含特定员工所有公司行的命名范围。

如果“employee”是970212-2398，那么我希望范围是

AlfaLaval
DeLaval

如果“employee”是970911-1287，那么我希望范围是

Kamel
Kanel

这可以使用Excel和/或VBA吗？

Answer 1

似乎有一些反对意见表明你会更好地使用另一个解决方案，但这看起来像Scripting.Dictionary对象的理想子，我喜欢和他们一起工作，所以你去吧。

Sub create_employee_named_ranges()
    Dim n As Long, r As Long, vEMP As Variant
    Dim dEMPs As New Scripting.Dictionary
    dEMPs.CompareMode = TextCompare

    With ActiveSheet
        For r = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
            If Not dEMPs.Exists(.Cells(r, 1).Value) Then
                dEMPs.Add Key:=.Cells(r, 1).Value, _
                  Item:=Chr(39) & .Name & Chr(39) & Chr(33) & .Cells(r, 2).Address
            Else
                dEMPs.Item(.Cells(r, 1).Value) = _
                  dEMPs.Item(.Cells(r, 1).Value) & Chr(44) & Chr(39) & .Name & Chr(39) & Chr(33) & .Cells(r, 2).Address
            End If
        Next r
    End With

    With ActiveWorkbook
        For n = 1 To .Names.Count
            If Left(.Names(n).Name, 4) = "enr_" Then _
                .Names(n).Delete
        Next n
        For Each vEMP In dEMPs
            .Names.Add Name:="enr_" & Replace(vEMP, Chr(45), Chr(95)), _
              RefersTo:=Chr(61) & dEMPs.Item(vEMP)
        Next vEMP
    End With

    dEMPs.RemoveAll: Set dEMPs = Nothing
End Sub

您必须进入VBE的工具，参考并将Microsoft Scripting Runtime添加到列表中。请注意，我无法使用实际的员工标识符，因为破折号是命名范围名称中的非法字符（可能是因为它们在减法中使用）所以我用下划线替换它们。

Answer 2

如果您想要做的是生成下拉列表，基于选择特定员工，我建议您从表格的该列中的过滤器中选择员工。然后，您可以在worksheet_change事件上自动运行VBA宏，或者手动设置运行宏的按钮，以生成下拉列表。

以下是设置＆＃34;公司下拉列表的示例。在单元格A1中，根据您为员工ID（或多个ID）选择的内容。

Option Explicit
Sub MakeCompanyList()
    Dim LO As ListObject
    Dim colCompanies As Collection
    Dim I As Long
    Dim RW As Long
    Dim S() As String

Set LO = Worksheets("sheet1").ListObjects("Table1")

'Get company list from the visible rows
Set colCompanies = New Collection
On Error Resume Next
With LO.ListColumns("Company").DataBodyRange
    For I = 1 To .Rows.Count
        If .Rows(I).Hidden = False Then _
            colCompanies.Add .Rows(I).Value, CStr(.Rows(I).Value)
    Next I
End With
On Error GoTo 0

ReDim S(1 To colCompanies.Count)
For I = 1 To UBound(S)
    S(I) = colCompanies(I)
Next I

With Worksheets("Sheet1").Range("A1").Validation
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=Join(S, ",")
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = "Select a Company"
        .ErrorTitle = ""
        .InputMessage = "Selec a Company"
        .ErrorMessage = "Oops"
        .ShowInput = True
        .ShowError = True
    End With
End Sub

使用值匹配的单元格创建命名范围？

2 个答案: