Microsoft Excel - Find data within mulitple columns and rows and return value from a corresponding column

In this example I am assigning operators to run one or more machines, and each machine may have more than one operators assigned to it.  In another list (same sheet), I want to show any and all machines where that operator is assigned to work.

In the attached file (couldn't attach, see below), the number of machines will remain constant, and can have 1 to 3 operators assigned to it.  The "Operator List" will be generated by VBA (in the actual file) based on who works that day (can be smaller or larger).

I would like for the "Assigments" column to 'look' for that operator in range B2:D7 and list all machines where that operator's name is found.  Note that the name may appear in any column or row, and more than once in a column.

The solution can be either a formula or VBA, the only restriction is that it must be compatible with Excel 2003.

EDIT: The upload tool seems broken to me, does this help...?

Machine	Operator 1	Operator 2	Operator 3		Operator List	Assignments
1	John	Paul			John	1,4
2	Amy				Amy	2
3	Sam	Paul			Paul	1,3
4	Mary	John	Julie		Mary	4
5	Sam				Julie	4,6
6	Julie				Sam	3,5

I have looked so a solution for a few hours now, but can't quite get there, any help is appreciated!

This should get you there:

Public Sub ListAssignments(ByVal rngInput As Excel.Range, ByVal rngDest As Excel.Range)

    Dim scpOperators        As Object

    Dim arrInput          As Variant
    Dim arrOutput         As Variant

    Dim intCol          As Integer
    Dim intCols         As Integer
    Dim lngLastRow        As Long
    Dim lngRow          As Long
    Dim lngIndex          As Long

    intCols = rngInput.Parent.UsedRange.Offset(0, rngInput.Parent.UsedRange.Columns.Count - 1).Column
    arrInput = rngInput.Resize(1, intCols - rngInput.Column + 1)
    For intCol = LBound(arrInput, 2) To UBound(arrInput, 2)
      If arrInput(1, intCol) = "" Then
        Exit For
      End If
    Next intCol
    If intCol > UBound(arrInput, 2) Then
      intCols = UBound(arrInput, 2)
    Else
      intCols = intCol
    End If

    intCol = rngInput.Column
    On Error Resume Next
    lngLastRow = rngInput.Parent.Columns(intCol).Find(What:="*", _
      After:=rngInput.Parent.Cells(1, intCol), _
      SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
      LookAt:=xlPart, LookIn:=xlValues).Row
    If Err <> 0 Then
      lngLastRow = 0
    End If
    On Error GoTo 0

    If lngLastRow > rngInput.Row Then
      arrInput = rngInput.Offset(1, 0).Resize(lngLastRow - rngInput.Row, intCols)
      Set scpOperators = CreateObject("Scripting.Dictionary")
      scpOperators.CompareMode = vbTextCompare
      For lngRow = LBound(arrInput) To UBound(arrInput)
        For intCol = 2 To UBound(arrInput, 2)
          If arrInput(lngRow, intCol) > "" Then
            If Not scpOperators.Exists(arrInput(lngRow, intCol)) Then
              scpOperators.Item(arrInput(lngRow, intCol)) = scpOperators.Count + 1
            End If
          End If
        Next intCol
      Next lngRow

      ReDim arrOutput(1 To scpOperators.Count, 1 To 2)
      lngRow = 0
      For Each v In scpOperators.Keys
        lngRow = lngRow + 1
        arrOutput(lngRow, 1) = v
      Next v
      For lngRow = LBound(arrInput) To UBound(arrInput)
        For intCol = 2 To UBound(arrInput, 2)
          If arrInput(lngRow, intCol) > "" Then
            lngIndex = scpOperators.Item(arrInput(lngRow, intCol))
            If arrOutput(lngIndex, 2) > "" Then
              arrOutput(lngIndex, 2) = arrOutput(lngIndex, 2) & ","
            End If
            arrOutput(lngIndex, 2) = arrOutput(lngIndex, 2) & arrInput(lngRow, 1)
          End If
        Next intCol
      Next lngRow

      intCol = rngDest.Column
      On Error Resume Next
      lngLastRow = rngDest.Parent.Columns(intCol).Find(What:="*", _
        After:=rngDest.Parent.Cells(1, intCol), _
        SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
        LookAt:=xlPart, LookIn:=xlValues).Row
      If Err <> 0 Then
        lngLastRow = rngDest.Row + 1
      End If
      rngDest.Offset(1, 0).Resize(lngLastRow - rngDest.Row, 2).ClearContents
      rngDest.Offset(1, 0).Resize(UBound(arrOutput), 2) = arrOutput
    End If

End Sub

A bit long, but I try to make robust code.  Call it like this:

   Call ListAssignments(Worksheets("Sheet1").Range("A1"), Worksheets("Sheet2").Range("A1"))

where Sheet1!A1 is the top-left cell of the input range, and Sheet2!A1 is the top left cell of the output range.

The code first finds out how many columns of input data you have, then how many rows, and moves the input data into arrInput.  Then it looks through the input array, building an index of operators.  Next, it builds an output array based on the number of operators, moves the operator names into it, then builds strings with the Machine numbers.  And, finally, it clears out any information previously in the destination and moves the array to the destination.

Hello R,

It is possible to do using functions - a bit messy though.

=SUBSTITUTE(SUBSTITUTE(CONCATENATE(ISNUMBER(MATCH(F2,A$2:D$2,0))*$A$2,",",ISNUMBER(MATCH(F2,A$3:D$3,0))*$A$3,",",ISNUMBER(MATCH(F2,A$4:D$4,0))*$A$4,",",ISNUMBER(MATCH(F2,A$5:D$5,0))*$A$5,",",ISNUMBER(MATCH(F2,A$6:D$6,0))*$A$6,",",ISNUMBER(MATCH(F2,A$7:D$7,0))*$A$7),",0",""),"0,","")

Enter in G2 and copy down.

Regards

Harry

Thanks a lot Wally, helped me again.

For more knowledge, does the array get dumped from memory after it is moved into the destination file?  I plan to call this everytime any of the input fileds are changed (assume this could be up to 100 times), so we can verify no operator is stretched too thin.  If it requires additional code to dump it from memory, can you provide that as well?

Again, thank you for helping me out on another one!

Thanks Harry,

Thats a pretty slick way of doing it.  I think I have another application that would benifit from this.  I do see what you mean by messy, for this case there are a total of 45 machines that remain fixed, so it would get a bit long.  But as I said, I have another task that this will fit nicely into and keep it VBA free.

Much appreciated.

Actually, I'm not quite sure about the array being emptied.  I think when it goes out of scope, it gets cleaned up.  It would be a bit cleaner to erase the arrays:

  Erase arrInput, arrOutput

and probably should clean up the objects:

  set rngInput = nothing
  set rngDest = nothing
  set scpOperators = nothing

I normally do clean up the objects, just forgot to here...