Return column header name if value in that row

[surkdidat]

Hi all


In Sheet 1, Column I, is a reference number (starting row 2) say, 12345

In Sheet 1, Row 1 are the column headers, starting in Column Q (ending on Column ES)

In Sheet 2 in column A, i have a long list of reference numbers.

To save me a lot of manual labour, what i would like is to return EVERY column header against the reference number in sheet 2, that has a value in it.

To be slightly more difficult, I only need the word (or words) AFTER a // in the Column Header name (There are no spaces between the // and he value I need to extract.

What I need to extract can be one word, or more, and various lengths.

EDIT : To update Columns references

(SHEET 1)	Column I	Column Q	Column R	Column S	Column T
(ROW 2)​	ABC//Horse	DEF//Fox	GHI//Dog	IJK//Koala Bear	LMN//Rabbit
23456	njklo		iojh	jop	gvyi
34567		hhhh
12345	fff	ghg	oiop	phgo0	809
87654		njnin			niin

(SHEET 2)
12345	Horse	Fox	Dog	Koala Bear	Rabbit
23456	Horse	Dog	Koala Bear	Rabbit
34567	Fox
87654	Fox	Rabbit

I hope that explains everything, and my manual example matches!!

 

[Peter_SSs]

In Sheet 2 in column A, i have a long list of reference numbers.

I have assumed that list actually starts in row 2.

If so, then see how this goes with a copy of your workbook.

Sub List_Hdrs()
  Dim d As Object
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, r As Long, c As Long, uba2 As Long
  
  Set d = CreateObject("Scripting.Dictionary")
  With Sheets("Sheet1")
    b = .Range("I1", .Range("I" & Rows.Count).End(xlUp)).Value
    For i = 2 To UBound(b)
      d(b(i, 1)) = i
    Next i
    With .Range("Q1:ES1")
      b = .Value
      .Replace What:="*//", Replacement:="", LookAt:=xlPart
      a = .Parent.Range("Q1:ES" & .Parent.Range("I" & Rows.Count).End(xlUp).Row).Value
      uba2 = UBound(a, 2)
      .Value = b
    End With
  End With
  With Sheets("Sheet2")
    b = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value
    ReDim Preserve b(1 To UBound(b), 1 To uba2 + 1)
    For i = 1 To UBound(b)
      If d.exists(b(i, 1)) Then
        r = d(b(i, 1))
        c = 1
        For j = 1 To uba2
          If Len(a(r, j)) > 0 Then
            c = c + 1
            b(i, c) = a(1, j)
          End If
        Next j
      End If
    Next i
    .Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
  End With
End Sub