From the list of items in column A, find each (if they exist) in Range("B2:F7") and list the header of that column (B1:F1) in column J. Column A items can occur under multiple headers in B1 to F1.

I'm sure this is the culprit line...

..Range("J100").End(xlUp).Offset(1, 0) = i.Offset(Cells.End(xlUp), 0).Value

Secondly, in column J where the header is listed, I am struggling to get the cell address of "i" next to header name in column K.

So an example would be in col J = Col_B_Header and in col K = $B$5

Regards,
Howard

Option Explicit

Sub ListHeader()

Dim lngLstRow As Long
Dim rngA As Range, i As Range

With Sheets("Sheet2")
lngLstRow = .UsedRange.Rows.Count
For Each rngA In .Range("A2:A" & lngLstRow)
For Each i In Range("B2:F7")
If i.Value = rngA Then
.Range("J100").End(xlUp).Offset(1, 0) _
= i.Offset(Cells.End(xlUp), 0).Value
End If
Next
Next
End With

End Sub

Hi Howard,

Am Sun, 11 Aug 2013 23:52:31 -0700 (PDT) schrieb Howard:

From the list of items in column A, find each (if they exist) in Range("B2:F7") and list the header of that column (B1:F1) in column J. Column A items can occur under multiple headers in B1 to F1.

I'm sure this is the culprit line...

.Range("J100").End(xlUp).Offset(1, 0) = i.Offset(Cells.End(xlUp), 0).Value

try:
Sub ListHeader2()
Dim lngLstRow As Long
Dim rngA As Range
Dim c As Range
Dim firstaddress As String
Dim i As Long

i = 1
With Sheets("Sheet2")
lngLstRow = .UsedRange.Rows.Count
For Each rngA In .Range("A2:A" & lngLstRow)
Set c = .Range("B2:F7").Find(rngA, LookIn:=xlValues)
If Not c Is Nothing Then
firstaddress = c.Address
Do
.Cells(i, "J") = .Cells(1, c.Column)
i = i + 1
Set c = .Range("B2:F7").FindNext(c)
Loop While Not c Is Nothing And c.Address < firstaddress
End If
Next
End With
End Sub


Regards
Claus B.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

try:

Sub ListHeader2()

Dim lngLstRow As Long

Dim rngA As Range

Dim c As Range

Dim firstaddress As String

Dim i As Long



i = 1

With Sheets("Sheet2")

lngLstRow = .UsedRange.Rows.Count

For Each rngA In .Range("A2:A" & lngLstRow)

Set c = .Range("B2:F7").Find(rngA, LookIn:=xlValues)

If Not c Is Nothing Then

firstaddress = c.Address

Do

.Cells(i, "J") = .Cells(1, c.Column)

i = i + 1

Set c = .Range("B2:F7").FindNext(c)

Loop While Not c Is Nothing And c.Address < firstaddress

End If

Next

End With

End Sub


Regards

Claus B.


Hi Claus,

I think this is doing partly what I want, I'll have to test it further. The order of listing in Col J is confusing. Does the code look the column A items staeting from the bottom to the top?

The part it does not do is there are no cell address' in column K of the "found column A item".

Regards,
Howard

Hi Howard,

Am Mon, 12 Aug 2013 01:22:52 -0700 (PDT) schrieb Howard:

The part it does not do is there are no cell address' in column K of the "found column A item".

sorry, I did not read carefully.
Try:

Sub ListHeader2()
Dim lngLstRow As Long
Dim rngA As Range
Dim c As Range
Dim firstaddress As String
Dim i As Long

i = 1
With Sheets("Sheet2")
lngLstRow = .UsedRange.Rows.Count
For Each rngA In .Range("A2:A" & lngLstRow)
Set c = .Range("B2:F7").Find(rngA, _
LookIn:=xlValues, after:=.Range("F7"))
If Not c Is Nothing Then
firstaddress = c.Address
Do
.Cells(i, "J") = .Cells(1, c.Column)
.Cells(i, "K") = c.Address
i = i + 1
Set c = .Range("B2:F7").FindNext(c)
Loop While Not c Is Nothing And c.Address < firstaddress
End If
Next
End With
End Sub



Regards
Claus B.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

Hi Howard,

Am Mon, 12 Aug 2013 01:22:52 -0700 (PDT) schrieb Howard:

The order of listing in Col J is confusing. Does the code look the column A items staeting from the bottom to the top?

the code looks from A2 to the bottom. For the search in B2:F7 you can
fix the searchorder with
Searchorder:=xlByRows or Searchorder:=xlByColumns
Or you look in column A for the strings in B2:F7:

Sub ListHeader3()
Dim lngLstRow As Long
Dim rngA As Range
Dim c As Range
Dim firstaddress As String
Dim i As Long

i = 1
With Sheets("Sheet2")
lngLstRow = .UsedRange.Rows.Count
For Each rngA In .Range("B2:F7")
Set c = .Range("A2:A" & lngLstRow).Find(rngA, _
LookIn:=xlValues, after:=.Range("A" & lngLstRow))
If Not c Is Nothing Then
firstaddress = c.Address
Do
.Cells(i, "J") = .Cells(1, rngA.Column)
.Cells(i, "K") = rngA.Address
i = i + 1
Set c = .Range("A2:A" & lngLstRow).FindNext(c)
Loop While Not c Is Nothing And c.Address < firstaddress
End If
Next
lngLstRow = .Cells(Rows.Count, "J").End(xlUp).Row
.Range("J1:K" & lngLstRow).RemoveDuplicates _
Columns:=Array(1, 2), Header:=xlNo
End With
End Sub


Regards
Claus B.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

On Monday, August 12, 2013 1:37:35 AM UTC-7, Claus Busch wrote:
Hi Howard,



Am Mon, 12 Aug 2013 01:22:52 -0700 (PDT) schrieb Howard:



The part it does not do is there are no cell address' in column K of the "found column A item".



sorry, I did not read carefully.

Try:



Sub ListHeader2()

Dim lngLstRow As Long

Dim rngA As Range

Dim c As Range

Dim firstaddress As String

Dim i As Long



i = 1

With Sheets("Sheet2")

lngLstRow = .UsedRange.Rows.Count

For Each rngA In .Range("A2:A" & lngLstRow)

Set c = .Range("B2:F7").Find(rngA, _

LookIn:=xlValues, after:=.Range("F7"))

If Not c Is Nothing Then

firstaddress = c.Address

Do

.Cells(i, "J") = .Cells(1, c.Column)

.Cells(i, "K") = c.Address

i = i + 1

Set c = .Range("B2:F7").FindNext(c)

Loop While Not c Is Nothing And c.Address < firstaddress

End If

Next

End With

End Sub


Regards

Claus B.



Very nice, and with the cell address' it is easy see to the lookup order, which is, of course, is as you have said.

The order is not important, but thanks for taking the time enlighten me.

Thanks again.

Regards,
Howard