Searching across columns

[Pablo]

I have a qorksheet that has with an unique value for each row under column A
and multiple columns/range, B2 - H40 that can have a value. I need to figure
out how to reflect the column heading, B1 - H1 for each cell populated within
the row/range. Ultimately, I would like a list on separate worksheet of the
row and column relationship.

Any ideas?

 

[Sheeloo]

Your requirement is not clear (at least to me).

Can you provide more details with some examples of the data you have?

 

[Pablo]

Lets say in column A is my unique records beginning at A2 (123,456,789,...).
Columns B through H are categories (Animals, Cars, Sports,... Money) that my
records could be associated with. Record 123 may be associated with Cars and
Money by using an "X" in the cells (C2 and H2). Record 456 is associated with
Animals, Cars, and Sports (B3, C3, and D3).

The result I am looking for would be on worksheet 2
123 | Cars
123 | Money
456 | Animals
456 | Cars
456 | Sports

 

[Sheeloo]

Understood... I will write a macro and share with you later today...

 

[Sheeloo]

Use this macro
See comments for understanding

Sub copyMacro()

Dim lastRow As Long
Dim i, j, k As Long

'Change Long to String in the statement below if Ids are not pure numbers
Dim Id As Long

Dim lastCol As Integer
' H is column 8, change it accordingly if your
' last column is different
lastCol = 8

'Find last row on Sheet1
With Worksheets("Sheet1")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

'Start at row 2 on sheet2
j = 2

'Loop through all rows in Sheet1
For i = 2 To lastRow
Id = Worksheets("Sheet1").Cells(i, 1).Value

'Loop through all columns in Sheet1 looking for X (x won't match)
For k = 2 To lastCol
'If all columns are blank for one id then
'that id won't be written to sheet2
If Worksheets("Sheet1").Cells(i, k).Value = "X" Then
'write to Sheet2
Worksheets("Sheet2").Cells(j, 1).Value = Id
Worksheets("Sheet2").Cells(j, 2).Value = _
Worksheets("Sheet1").Cells(1, k).Value
'increment row number on Sheet2
j = j + 1
End If
Next k

Next i

End Sub

 

[Pablo]

Sheelo - This works perfectly. Thanks

Use this macro
See comments for understanding

Sub copyMacro()

Dim lastRow As Long
Dim i, j, k As Long

'Change Long to String in the statement below if Ids are not pure numbers
Dim Id As Long

Dim lastCol As Integer
' H is column 8, change it accordingly if your
' last column is different
lastCol = 8

'Find last row on Sheet1
With Worksheets("Sheet1")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

'Start at row 2 on sheet2
j = 2

'Loop through all rows in Sheet1
For i = 2 To lastRow
Id = Worksheets("Sheet1").Cells(i, 1).Value

'Loop through all columns in Sheet1 looking for X (x won't match)
For k = 2 To lastCol
'If all columns are blank for one id then
'that id won't be written to sheet2
If Worksheets("Sheet1").Cells(i, k).Value = "X" Then
'write to Sheet2
Worksheets("Sheet2").Cells(j, 1).Value = Id
Worksheets("Sheet2").Cells(j, 2).Value = _
Worksheets("Sheet1").Cells(1, k).Value
'increment row number on Sheet2
j = j + 1
End If
Next k

Next i

End Sub