Checking sheet for values and capturing column name

[Complete Newb]

It's weird that every time I think I'm going to know how to do something, it
winds up I get 1/4 or 1/2 way there and then stuck.

On Sheet1 I have one column of text values (about 500) in Column A (w/
header of "Unique"). On Sheet2 there are many columns and many rows, with
all kinds of values everywhere. What I need to do is:

Run through Sheet2, and for every occurrence of a value in Sheet1's "Unique"
column, enter the column heading(s) of the column(s) that value is in in
Column 2 of Sheet1 next to that value.

For instance, Sheet1's "Unique" column has:

Gear
Tranny
Door

On Sheet2:

- The value "Gear" is located in A5 (Column heading of "Parts"), E114
(Column heading of "Labor"), and G55 (Column heading of "Misc").
- The value "Tranny" is in B45 (Column heading of "Traps")
- The value "Door" is in A88 (Column heading of "Parts") and E6 (Column
heading of "Labor").

So, after I run a sub procedure, Sheet1 should show the following:

Gear Parts,Labor,Misc
Tranny Traps
Door Parts, Labor

I don't care if it's easier to put each column header instance in a separate
column on Sheet1 (instead of values separated by commas), because I can
combine them as a separate step. Also, if getting the actual column header
value is a big complication, I don't mind just returning the column letters
and then I can run a sub or use a formula to change column letters to their
respective header names as a separate step also.

Can anyone help me figure out how to do this?

Any help is greatly appreciated, and thanks for reading.

 

[Tom Ogilvy]

Option Explicit
Sub GetcolumnHeaders()
Dim fAddr As String
Dim sStr As String, s As String
Dim rng As Range
Dim rng2 As Range
Dim cell As Range
Dim cell1 As Range
With Worksheets("Sheet1")
Set rng = .Range(.Range("A2"), _
.Range("A2").End(xlDown))
End With
For Each cell In rng
Set rng2 = Nothing
sStr = cell.Value
With Worksheets("sheet2").Cells
Set rng = .Find( _
What:=sStr, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not rng Is Nothing Then
fAddr = rng.Address
Do
If rng2 Is Nothing Then
Set rng2 = rng
Else
Set rng2 = Application.Union(rng2, rng)
End If
Set rng = .FindNext(rng)
Loop While rng.Address <> fAddr
End If
cell.Offset(0, 1).ClearContents
s = ""
If Not rng2 Is Nothing Then

For Each cell1 In rng2
s = s & _
cell1.Parent.Cells(1, _
cell1.Column) & ","
Next
cell.Offset(0, 1).Value = Left(s, Len(s) - 1)
End If
End With
Next

End Sub

 

[JE McGimpsey]

One way:

Public Sub ListUniqueHeaders()
Dim rCell As Range
Dim rUnique As Range
Dim rFound As Range
Dim sColumnHeaders As String
Dim sFirstAddress As String
With Worksheets("Sheet1")
Set rUnique = .Cells.Find( _
What:="Unique", _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
Lookat:=xlWhole, _
MatchCase:=False)
If rUnique Is Nothing Then
MsgBox "'Unique' column not found)"
Exit Sub
Else
Set rUnique = .Range(rUnique.Offset(1, 0), _
.Cells(.Rows.Count, rUnique.Column).End(xlUp))
If rUnique.Cells.Count = 1 Then
MsgBox "No values in 'Unique' column"
Exit Sub
End If
End If
End With
With Sheets("Sheet2")
For Each rCell In rUnique
Set rFound = .Cells.Find( _
What:=rCell.Text, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
Lookat:=xlPart, _
MatchCase:=False)
If Not rFound Is Nothing Then
sFirstAddress = rFound.Address
Do
sColumnHeaders = sColumnHeaders & "," & _
rFound.EntireColumn.Cells(1).Text
Set rFound = .Cells.FindNext(After:=rFound)
Loop Until rFound.Address = sFirstAddress
rCell.Offset(0, 1).Value = Mid(sColumnHeaders, 2)
sColumnHeaders = vbNullString
Set rFound = Nothing
End If
Next rCell
End With
End Sub

 

[Complete Newb]

Tom:

That was amazing; totally worked. Tom, you continue to carry a significant
amount of us newbies. I still have several examples you provided on the
newsgroups a long time ago (not trying to say you're old or anything), that
I continue to use as the basis for my own modifications when I need to
execute similar, but different, tasks.

I have one questions about the results of this; I had not anticipated that
many of these values would actually be in ONE column several times. Is
there a way to either:

- Tell the VBA in your example to ignore multiple identical instances or
- (and this one would probably be easier) Delete duplicate values in each
cell's comma-delimited list in the results sheet (ie.
"Labor,Labor,Labor,Parts" would become "Labor,Parts")

Again, thank you very much.

 

[CompleteNewb]

JE:

Thanks for offering that VBA. From the looks of it, this would actually
address the issue with multiple identical column header entries (like if a
value from Sheet1 happens to be in A5, A10, A122, etc.). However, when I
try it, it just goes to the msgbox saying no unique values found, which I
know can't be the case. I made sure the sheet titles are correct; do you
know why the check returns the msgbox?

Thanks again, your help is very much appreciated.

 

[Tom Ogilvy]

Glad you find some of my stuff useful:

Option Explicit
Sub GetcolumnHeaders()
Dim fAddr As String
Dim sStr As String, s As String
Dim rng As Range
Dim rng2 As Range
Dim cell As Range
Dim cell1 As Range
Dim cell2 As Range
Dim nodupes As Collection
Dim itm As Variant
With Worksheets("Sheet1")
Set rng = .Range(.Range("A2"), _
.Range("A2").End(xlDown))
End With
For Each cell In rng
Set rng2 = Nothing
sStr = cell.Value
With Worksheets("sheet2").Cells
Set rng = .Find( _
What:=sStr, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not rng Is Nothing Then
fAddr = rng.Address
Do
If rng2 Is Nothing Then
Set rng2 = rng
Else
Set rng2 = Application.Union(rng2, rng)
End If
Set rng = .FindNext(rng)
Loop While rng.Address <> fAddr
End If
cell.Offset(0, 1).ClearContents
s = ""
If Not rng2 Is Nothing Then
Set nodupes = New Collection
For Each cell1 In rng2
Set cell2 = cell1.Parent.Cells(1, cell1.Column)
On Error Resume Next
nodupes.Add cell2.Value, cell2.Text
On Error GoTo 0
Next
'
' Optional Sort code would go here
'
For Each itm In nodupes
s = s & itm & ","
Next
cell.Offset(0, 1).Value = Left(s, Len(s) - 1)
End If
End With
Next

End Sub

should do it. If you want them sorted, see John Walkenbach's site
http://www.j-walk.com/ss/excel/tips/tip47.htm
see the sort collection part of the code.

 

[CompleteNewb]

Direct hit again, Mr. Ogilvy.

This one is going to take serious study. From the code, I can usually
figure out what does what and how to use it in the future, but a lot of
lines in this one are things I'm not familiar with.

Is there a place that walks newbies through how to use common vba lines,
like what to write to cycle through all cells, certain ranges or selections,
etc.? I really stink with the "With" things and "Do Until" and "Loop." I
usually record macros and then go through and replace/alter stuff and delete
unnecessary stuff, but I've never grasped the above types of things, because
you can't really record it.

Thanks again for your help, it is truly appreciated.

 

[Tom Ogilvy]

It is looking in sheet 1 for the word Unique to identify in which column
the list of unique words is located. For some reason it isn't finding it.
I just assumed it was in column 1 of sheet1 like you said.

It doesn't address the problem of multiple identical column header entries.

 

[Tom Ogilvy]

Get a book like Excel [version] VBA Step by Step by Read Jacobson or
John Walkenbach's power programming book (for whatever version).
http://www.j-walk.com/ss/excel link on the left to his books.

 

[JE McGimpsey]

I didn't see that you always have the unique items were always in column
A, so the first part of the macro looks for the title 'Unique' in the
first sheet.

To eliminate duplicates, it would be easiest to loop through the
populated columns.