问题
ManagerEmployeeSheet
A B
1 manager Employee
2 M1 E1
3 M1 E2
4 M1 E44
5 M1 E41
6 M1 E34
7 M2 E100
8 M2 E17
9 M2 E29 and so on
I am making a dynamic dashboard where I need the employees under each manager to be dynamically reflected.
DashboardSheet
A B
1 Input Manager M1 #basically user inputs one manager name here in this cell
2 E1
3 E2
4 E44
5 E41
6 E34
So when I input M1 manager in cell B1 of DashboardSheet , I should get all employees under him in below cells, similarly if I input any other manager , I should get all employees under that manager. Vlookup alone will return only the first employee corresponding to the manager, but i need all employees under him.
I have read that maybe vlookup with offset can do this. But I am not sure.
Can anyone please help?
回答1:
If you have Office365 then you can easily do that with Filter formula. Try below formula as per screenshot.
=FILTER(B2:B9,A2:A9=E1)
If you do not have Office365 then use INDEX() and AGGREGATE() formula together. As per my screenshot use below formula to D2 cell.
=IFERROR(INDEX($B$2:$B$9,AGGREGATE(15,6,ROW($1:$9)/($A$2:$A$9=$E$1),ROW(1:1))),"")
回答2:
What I started out on the assertion that what @Harun24HR can do with one formula VBA should be able to do with one line of code became the epic effort shown below. Obviously I failed. In the project's defense I point out that where you have formulas in a worksheet you should add protection to the sheet to prevent your formulas from being damaged and that adds significantly to the management effort, too.
With that said, the code below is a Worksheet_Change procedure which must be in the code module of your Dashboard sheet and responds to a change in cell B1 (TriggerRange). The function it calls can go with it to the same location. Adjust the 3 constants at the top of the code (a convenience @Harun can't offer because it's one of the advantages of using VBA). The point is that you can modify any or all of the 3 constants and never need to touch the rest of the code. That makes management whole a lot easier.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
' 083
Const TriggerRange As String = "B1" ' cell where the change occurs
Const MgrClm As String = "A" ' change to suit
Const EmpClm As String = "C" ' change to suit
Dim List As Variant ' list of employees under one manager
Dim OutputRng As Range ' range to write result to
With Target
If .Address(0, 0) = TriggerRange Then
Set OutputRng = Range(.Offset(1), Cells(.Rows.Count, .Column).End(xlDown))
' keep one blank between the last employee and any other column content
OutputRng.ClearContents
List = EmployeeList(.Value, Columns(MgrClm).Column, Columns(EmpClm).Column)
' write to the cell below the changed cell
Set OutputRng = .Offset(1).Resize(UBound(List))
OutputRng.Value = Application.Transpose(List)
End If
End With
End Sub
Private Function EmployeeList(ByVal Crit As String, _
ByVal MgrClm As Long, _
ByVal EmpClm As Long) As Variant
' 083
Dim Fun As Variant ' function return array
Dim FltMode As Boolean ' Filter set by user
Dim Rng As Range ' working range
Dim RngArea As Range ' areas of the filtered range
Dim n As Long ' index to Fun
Dim R As Long ' loop counter: Rows
With Worksheets("Employees")
If .AutoFilterMode Then
.Cells.AutoFilter
FltMode = True
End If
Set Rng = .Range(.Cells(1, 1), .Cells(.Rows.Count, EmpClm).End(xlUp))
With Rng
ReDim Fun(1 To .Rows.Count)
.AutoFilter
.AutoFilter Field:=MgrClm, Criteria1:=Crit
End With
On Error Resume Next
Set Rng = .AutoFilter.Range.Offset(1, 0) _
.Resize(.AutoFilter.Range.Rows.Count - 1) _
.SpecialCells(xlCellTypeVisible) ' omit header row
If Err.Number = 0 Then
On Error GoTo 0
For Each RngArea In Rng.Areas
With RngArea
For R = 1 To .Rows.Count
n = n + 1
Fun(n) = .Cells(R, EmpClm).Value
Next R
End With
Next RngArea
End If
If Not FltMode Then .AutoFilter
End With
If n = 0 Then
n = 1
Fun(n) = "No subordinates"
End If
ReDim Preserve Fun(1 To n)
EmployeeList = Fun
End Function
回答3:
Please, try the next VBA approach:
- Copy the next
Subin a standard module. It will create a validation cell keeping the unique Manager names (not required, but helpful I think):
Sub setValidationUnique()
Dim shM As Worksheet, shD As Worksheet, rngV As Range, dict As Object
Dim lastRM As Long, i As Long
Set shM = Worksheets("ManagerEmployeeSheet")'use here your sheet name
Set shD = Worksheets("DashboardSheet") 'use here your sheet name
lastRM = shM.Range("A" & Rows.count).End(xlUp).row
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To lastRM
dict(shM.Range("A" & i).value) = 1
Next i
Set rngV = shD.Range("B1")
With rngV.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:=Join(dict.Keys, ",")
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = True
End With
With shD.Range("A1")
.value = "Input Manager"
.Font.Bold = True
.EntireColumn.AutoFit
End With
shD.Activate: rngV.Select
End Sub
- In the worksheet "DashboardSheet" module, copy the next event:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) <> "B1" Then Exit Sub
Dim shM As Worksheet, arrE As Variant, k As Long
Dim lastRM As Long, i As Long
Set shM = Worksheets("ManagerEmployeeSheet")
lastRM = shM.Range("A" & Rows.count).End(xlUp).row
ReDim arrE(0 To lastRM)
For i = 2 To lastRM
If shM.Range("A" & i).value = Target.value Then
arrE(k) = shM.Range("B" & i).value: k = k + 1
End If
Next i
ReDim Preserve arrE(k - 1)
Target.Parent.Range(Target.Offset(1, -1), Target.Offset(1, -1).End(xlDown)).Clear
Application.EnableEvents = False
Target.Offset(1, -1).Resize(UBound(arrE) + 1, 1).value = WorksheetFunction.Transpose(arrE)
Application.EnableEvents = True
End Sub
Take care to appropriately name the necessary sheets, or name it "ManagerEmployeeSheet" and "DashboardSheet".
Play with the validated cell ("B1"), see the result and send some feedback.
来源：https://stackoverflow.com/questions/63665868/vlookup-for-an-array-of-values