Posts by jaslake

Option Explicit
Sub Test_UniqueArray()
    Dim LC As String
    Dim LR As Long
    Dim a As Variant
    Dim b As Variant
    Dim pCell As Range
    Dim aCell As Range
    Dim Project As String
    Dim iRng As Range    'this is the Item Range
    Dim iCell As Range
    Dim eRng As Range    'this is the Elements Range
    Dim i As Long
    Dim OffSetRow As Long
 
    Application.ScreenUpdating = False
    Sheet2.Cells.ClearContents
    LC = ColumnLetter(Cells(Sheet1.Range("B6").row, Columns.Count).End(xlToLeft).Column)
    a = WorksheetFunction.Transpose(Worksheets("Sheet1").Range("C5:" & LC & "5").Value)
    a = UniqueArray(a)
    Sheet2.Range("D6").Resize(1, UBound(a) + 1).Value = a
    Project = Application.InputBox _
              (Prompt:="Please Pick A Project", _
               Title:="PICK A PROJECT", Type:=2)
    With Sheet1
        LR = .Range("B" & .Rows.Count).End(xlUp).row
        If Project = "" Then Exit Sub
        Set pCell = Range("B6:B" & LR).Find _
                    (What:=Project, LookIn:=xlFormulas)
        '        Application.GoTo pCell
        Set iRng = Range("C5:" & LC & "5")
        Set eRng = Range("B" & pCell.row & ":" & LC & pCell.row)
        For Each aCell In Sheet2.Range("D6").Resize(1, UBound(a) + 1)
            Dim eFound() As Variant
            ReDim eFound(0)
            OffSetRow = pCell.row - iRng.row
            For Each iCell In iRng
                If iCell = aCell Then
'                    Application.GoTo iCell
                    eFound(UBound(eFound)) = iCell.OffSet(OffSetRow, 0).Value
                    ReDim Preserve eFound(UBound(eFound) + 1)
                End If
            Next iCell
            b = eFound()
            For i = LBound(eFound) To UBound(eFound)
                aCell.OffSet((i + 1), 0) = eFound(i)
            Next i
        Next aCell
    End With
    Application.ScreenUpdating = True
End Sub
 
 
Function UniqueArray(anArray As Variant) As Variant
    'Adapted from [URL]http://www.vbaexpress.com/forum/showthread.php?t=24917[/URL]
    'Requires, Tools > Reference > Microsoft Scripting Runtime, scrrun.dll
    Dim d As New Scripting.Dictionary, a As Variant
    With d
        .CompareMode = TextCompare
        For Each a In anArray
            If Not Len(a) = 0 And Not .Exists(a) Then
                .Add a, Nothing
            End If
        Next a
        UniqueArray = d.keys
    End With
    Set d = Nothing
End Function
 
 
'From [URL]http://www.freevbcode.com/ShowCode.asp?ID=4303[/URL]
Function ColumnLetter(ColumnNumber As Long) As String
    If ColumnNumber > 26 Then
        ' 1st character:  Subtract 1 to map the characters to 0-25,
        '                 but you don't have to remap back to 1-26
        '                 after the 'Int' operation since columns
        '                 1-26 have no prefix letter
        ' 2nd character:  Subtract 1 to map the characters to 0-25,
        '                 but then must remap back to 1-26 after
        '                 the 'Mod' operation by adding 1 back in
        '                 (included in the '65')
        ColumnLetter = Chr(Int((ColumnNumber - 1) / 26) + 64) & _
                       Chr(((ColumnNumber - 1) Mod 26) + 65)
    Else
        ' Columns A-Z
        ColumnLetter = Chr(ColumnNumber + 64)
    End If
End Function